diff options
| author | Martin Liska <mliska@suse.cz> | 2022-09-12 10:43:19 +0200 |
|---|---|---|
| committer | Martin Liska <mliska@suse.cz> | 2022-09-12 10:43:19 +0200 |
| commit | fdb97cd0b7d15efa39ba79dca44be93debb0ef12 (patch) | |
| tree | 65a6d95503fb9897bda29c72a629e57bb773d1c1 /gcc | |
| parent | 918bc838c2803f08e4d7ccd179396d48cb8ec804 (diff) | |
| parent | 643ae816f17745a77b62188b6bf169211609a59b (diff) | |
| download | gcc-fdb97cd0b7d15efa39ba79dca44be93debb0ef12.zip gcc-fdb97cd0b7d15efa39ba79dca44be93debb0ef12.tar.gz gcc-fdb97cd0b7d15efa39ba79dca44be93debb0ef12.tar.bz2 | |
Merge branch 'master' into devel/sphinx
Diffstat (limited to 'gcc')
377 files changed, 15398 insertions, 31580 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 958ccc6..e670cae 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,493 @@ +2022-09-10 Takayuki 'January June' Suwa <jjsuwa_sys3175@yahoo.co.jp> + + * config/xtensa/xtensa.cc (xtensa_constantsynth): + Add new pattern for the abovementioned case. + +2022-09-10 Akari Takahashi <akaritakahashioss@gmail.com> + Segher Boessenkool <segher@kernel.crashing.org> + + * config/rs6000/rs6000.cc (get_memref_parts): Regularize some code. + +2022-09-09 Takayuki 'January June' Suwa <jjsuwa_sys3175@yahoo.co.jp> + + * config/xtensa/xtensa.md: Rewrite the split pattern that performs + the abovementioned process so that insns that overwrite clobbered + register no longer need to be contiguous. + (DSC): Remove as no longer needed. + +2022-09-09 Takayuki 'January June' Suwa <jjsuwa_sys3175@yahoo.co.jp> + + * config/xtensa/xtensa.cc (machine_function): New boolean member as + a flag that controls whether to emit the insns for stack pointer + adjustment inside of the pro/epilogue. + (xtensa_emit_adjust_stack_ptr): New function to share the common + codes and to emit insns if not inhibited. + (xtensa_expand_epilogue): Change to use the function mentioned + above when using the CALL0 ABI. + (xtensa_expand_prologue): Ditto. + And also change to set the inhibit flag used by + xtensa_emit_adjust_stack_ptr() to true if the stack pointer is only + used for its own adjustment. + +2022-09-09 David Malcolm <dmalcolm@redhat.com> + + * doc/invoke.texi (Static Analyzer Options): Add + -Wanalyzer-exposure-through-uninit-copy. + +2022-09-09 David Malcolm <dmalcolm@redhat.com> + + * Makefile.in (ANALYZER_OBJS): Add + analyzer/known-function-manager.o. + +2022-09-09 Tobias Burnus <tobias@codesourcery.com> + + * config/nvptx/mkoffload.cc (struct id_map): Add 'dim' member. + (record_id): Store func name without quotes, store dim separately. + (process): For GOMP_REQUIRES_REVERSE_OFFLOAD, check that -march is + at least sm_35, create '$offload_func_table' global array and init + with reverse-offload function addresses. + * config/nvptx/nvptx.cc (write_fn_proto_1, write_fn_proto): New + force_public attribute to force .visible. + (nvptx_declare_function_name): For "omp target + device_ancestor_nohost" attribut, force .visible/TREE_PUBLIC. + +2022-09-09 Tobias Burnus <tobias@codesourcery.com> + + * config/gcn/mkoffload.cc (process_asm): Create .offload_func_table, + similar to pre-existing .offload_var_table. + +2022-09-09 Joseph Myers <joseph@codesourcery.com> + + * ginclude/stddef.h [__STDC_VERSION__ > 201710L] (unreachable): + New macro. + +2022-09-09 Kewen Lin <linkw@linux.ibm.com> + + PR middle-end/106833 + * tree.cc (verify_opaque_type): New function. + (verify_type): Call verify_opaque_type for OPAQUE_TYPE. + +2022-09-09 Kwok Cheung Yeung <kcy@codesourcery.com> + + * config/gcn/gcn-builtins.def (FABSVF, LDEXPVF, LDEXPV, FREXPVF_EXP, + FREXPVF_MANT, FREXPV_EXP, FREXPV_MANT): Add new builtins. + * config/gcn/gcn-protos.h (gcn_dconst1over2pi): New prototype. + * config/gcn/gcn-valu.md (MATH_UNOP_1OR2REG, MATH_UNOP_1REG, + MATH_UNOP_TRIG): New iterators. + (math_unop): New attributes. + (<math_unop><mode>2, <math_unop><mode>2<exec>, + <math_unop><mode>2, <math_unop><mode>2<exec>, + *<math_unop><mode>2_insn, *<math_unop><mode>2<exec>_insn, + ldexp<mode>3, ldexp<mode>3<exec>, + frexp<mode>_exp2, frexp<mode>_mant2, + frexp<mode>_exp2<exec>, frexp<mode>_mant2<exec>): New instructions. + (<math_unop><mode>2, <math_unop><mode>2<exec>): New expanders. + * config/gcn/gcn.cc (init_ext_gcn_constants): Update definition of + dconst1over2pi. + (gcn_dconst1over2pi): New. + (gcn_builtin_type_index): Add entry for v64df type. + (v64df_type_node): New. + (gcn_init_builtin_types): Initialize v64df_type_node. + (gcn_expand_builtin_1): Expand new builtins to instructions. + (print_operand): Fix assembler output for 1/(2*PI) constant. + * config/gcn/gcn.md (unspec): Add new entries. + +2022-09-09 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106722 + * tree-predcom.cc (ref_at_iteration): Do not associate the + constant part of the offset into the MEM_REF offset + operand, across a non-zero offset. + +2022-09-09 Kito Cheng <kito.cheng@sifive.com> + + * common/config/riscv/riscv-common.cc (RISCV_USE_CUSTOMISED_MULTI_LIB): + Move forward for cover all all necessary functions for suppress + unused function warnings. + (riscv_multi_lib_check): Move forward, and tweak message to suppress + -Werror=format-diag warning. + +2022-09-09 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106881 + * gimple-predicate-analysis.cc (simple_control_dep_chain): + Add only non-fallthru edges and avoid the same set of edges + as compute_control_dep_chain_pdom does. + +2022-09-09 Jan-Benedict Glaw <jbglaw@lug-owl.de> + + * doc/tm.texi.in (TARGET_OVERRIDES_FORMAT_ATTRIBUTES): Document requirement + of TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT being defined as well. + * doc/tm.texi: Regenerate. + +2022-09-09 Martin Liska <mliska@suse.cz> + + * optc-save-gen.awk: Always compare array option values with memcmp. + +2022-09-08 Jonathan Wakely <jwakely@redhat.com> + + PR c++/106838 + * doc/extend.texi (Type Traits): Fix requirements. Document + __is_aggregate and __is_final. + +2022-09-08 Tim Lange <mail@tim-lange.me> + + PR analyzer/106625 + * doc/invoke.texi: + State that the checker also reasons about symbolic values. + +2022-09-08 Richard Sandiford <richard.sandiford@arm.com> + + PR tree-optimization/106886 + * tree-vect-slp.cc (vect_optimize_slp_pass::get_result_with_layout): + Fix copying of scalar stmts. + +2022-09-08 Chung-Lin Tang <cltang@codesourcery.com> + + * config/nios2/linux.h (MUSL_DYNAMIC_LINKER): Add #undef before #define. + +2022-09-08 Richard Biener <rguenther@suse.de> + + PR middle-end/106870 + * gimple-harden-conditionals.cc (insert_check_and_trap): + Set the control-altering flag on the built IFN_TRAP. + * gimple.cc (gimple_build_builtin_unreachable): Likewise. + * tree-cfg.cc (handle_abnormal_edges): Set the control-altering + flag on the .ABNORMAL_DISPATCHER call. + * tree-cfgcleanup.cc (cleanup_call_ctrl_altering_flag): Avoid + resetting the control altering flag for ECF_NORETURN calls. + (cleanup_control_flow_bb): Set the control altering flag on + discovered noreturn calls. + * symtab-thunks.cc (expand_thunk): Set the control altering + flag for the noreturn tailcall case. + * tree-eh.cc (lower_resx): Likewisw for trap and unwind_resume + calls. + +2022-09-08 Jakub Jelinek <jakub@redhat.com> + + * omp-expand.cc (expand_omp_ordered_sink): Add CONT_BB argument. + Add doacross(sink:omp_cur_iteration-1) support. + (expand_omp_ordered_source_sink): Clear counts[fd->ordered + 1]. + Adjust expand_omp_ordered_sink caller. + (expand_omp_for_ordered_loops): If counts[fd->ordered + 1] is + non-NULL, set that variable to true at the start of outermost + non-collapsed loop and set it to false at the end of innermost + ordered loop. + (expand_omp_for_generic): If fd->ordered, allocate + 1 + (fd->ordered - fd->collapse) further elements in counts array. + Copy to counts + 2 + fd->ordered the counts of fd->collapse .. + fd->ordered - 1 loop if any. + +2022-09-08 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106881 + * gimple-predicate-analysis.cc (compute_control_dep_chain_pdom): + Add only non-fallthru edges and avoid the same set of edges + as the caller does. + +2022-09-08 Aldy Hernandez <aldyh@redhat.com> + + * gimple-range-fold.cc + (fold_using_range::range_of_builtin_int_call): Use fpclassify like API. + * range-op-float.cc (finite_operand_p): Same. + (finite_operands_p): Same. + (foperator_lt::fold_range): Same. + (foperator_le::fold_range): Same. + (foperator_gt::fold_range): Same. + (foperator_ge::fold_range): Same. + (foperator_unordered::fold_range): Same. + (foperator_unordered::op1_range): Same. + (foperator_ordered::fold_range): Same. + * value-range.cc (frange::set_nan): Same. + (frange::set_signbit): Same. + (frange::union_): Same. + (frange::intersect): Same. + (frange::operator==): Same. + (frange::singleton_p): Same. + (frange::verify_range): Same. + (range_tests_nan): Same. + (range_tests_floats): Same. + * value-range.h(frange::known_finite): New. + (frange::maybe_inf): New. + (frange::known_inf): New. + (frange::maybe_nan): New. + (frange::known_nan): New. + (frange::known_signbit): New. + +2022-09-08 Iain Buclaw <ibuclaw@gdcproject.org> + + * config/darwin-d.cc: Include tm.h. + * config/dragonfly-d.cc: Likewise. + * config/freebsd-d.cc: Remove memmodel.h. + * config/glibc-d.cc: Likewise. + * config/netbsd-d.cc: Include tm.h. + * config/openbsd-d.cc: Likewise. + * config/sol2-d.cc: Likewise. + +2022-09-08 Christophe Lyon <christophe.lyon@arm.com> + + * config/arm/mve.md (mve_vqshluq_n_s<mode>): Use + MVE_pred/MVE_constraint instead of mve_imm_7/Ra. + (mve_vqshluq_m_n_s<mode>): Likewise. + (mve_vqrshrnbq_n_<supf><mode>): Use MVE_pred3/MVE_constraint3 + instead of mve_imm_8/Rb. + (mve_vqrshrunbq_n_s<mode>): Likewise. + (mve_vqrshrntq_n_<supf><mode>): Likewise. + (mve_vqrshruntq_n_s<mode>): Likewise. + (mve_vrshrnbq_n_<supf><mode>): Likewise. + (mve_vrshrntq_n_<supf><mode>): Likewise. + (mve_vqrshrnbq_m_n_<supf><mode>): Likewise. + (mve_vqrshrntq_m_n_<supf><mode>): Likewise. + (mve_vrshrnbq_m_n_<supf><mode>): Likewise. + (mve_vrshrntq_m_n_<supf><mode>): Likewise. + (mve_vqrshrunbq_m_n_s<mode>): Likewise. + (mve_vsriq_n_<supf><mode): Use MVE_pred2/MVE_constraint2 instead + of mve_imm_selective_upto_8/Rg. + (mve_vsriq_m_n_<supf><mode>): Likewise. + +2022-09-08 Jiufu Guo <guojiufu@linux.ibm.com> + + * config/rs6000/rs6000.md (splitter for set to and_mask constants): + Use int_reg_operand (instead of int_reg_operand_not_pseudo). + (splitter for multi-insn constant loads): Ditto. + +2022-09-08 Sebastian Huber <sebastian.huber@embedded-brains.de> + + * config/rs6000/rtems.h (CPP_OS_DEFAULT_SPEC): Define __PPC_VRSAVE__ if + -mvrsave is present. + * config/rs6000/t-rtems: Add -mvrsave multilib variants for + -mcpu=e6500. + +2022-09-07 Martin Liska <mliska@suse.cz> + + * configure.ac: Restore detection of HAVE_XCOFF_DWARF_EXTRAS. + * config/rs6000/rs6000.cc (HAVE_XCOFF_DWARF_EXTRAS): Reset it. + * configure: Regenerate. + * config.in: Regenerate. + +2022-09-07 Surya Kumari Jangala <jskumari@linux.ibm.com> + + PR rtl-optimization/105586 + * sched-rgn.cc (save_state_for_fallthru_edge): New function. + (schedule_region): Use it for all blocks. + +2022-09-07 Joseph Myers <joseph@codesourcery.com> + + * ginclude/stdalign.h [defined __STDC_VERSION__ && + __STDC_VERSION__ > 201710L]: Disable all content. + * ginclude/stdbool.h [defined __STDC_VERSION__ && __STDC_VERSION__ + > 201710L] (bool, true, false): Do not define. + +2022-09-07 Martin Liska <mliska@suse.cz> + + PR bootstrap/106855 + * collect2.cc (scan_prog_file): Restore if XCOFF_DEBUGGING_INFO. + * config/rs6000/rs6000.cc (rs6000_option_override_internal): + Restore usage of XCOFF_DEBUGGING_INFO. + * config/rs6000/xcoff.h (XCOFF_DEBUGGING_INFO): Restore. + * dwarf2asm.cc (XCOFF_DEBUGGING_INFO): Restore support for + XCOFF_DEBUGGING_INFO. + (dw2_asm_output_nstring): Likewise. + (USE_LINKONCE_INDIRECT): Likewise. + * dwarf2out.cc (XCOFF_DEBUGGING_INFO): Likewise. + (HAVE_XCOFF_DWARF_EXTRAS): Likewise. + (output_fde): Likewise. + (output_call_frame_info): Likewise. + (have_macinfo): Likewise. + (add_AT_loc_list): Likewise. + (add_AT_view_list): Likewise. + (output_compilation_unit_header): Likewise. + (output_pubnames): Likewise. + (output_aranges): Likewise. + (output_line_info): Likewise. + (output_macinfo): Likewise. + (dwarf2out_finish): Likewise. + (dwarf2out_early_finish): Likewise. + +2022-09-07 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106866 + * tree-ssa-dce.cc (eliminate_unnecessary_stmts): When + we changed cfun->calls_setjmp make sure to purge all + abnormal call edges. + +2022-09-07 Xianmiao Qu <cooper.qu@linux.alibaba.com> + + * config/csky/csky.cc (csky_emit_compare_float): Fix the expanding of + float LE comparing with zero for fpuv3. + * config/csky/csky.h (TARGET_SUPPORT_FPV2): New, true if any fpuv2 + features are enabled. + +2022-09-07 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106860 + * tree-ssa-loop-split.cc (split_loop): Find the exit to + latch edge from the loop exit edge instead of from the + latch. Verify we're going to find it. + +2022-09-07 Richard Biener <rguenther@suse.de> + + * gimple-predicate-analysis.cc (dfs_mark_dominating_region): + Adjust to take the region exit source as argument. + (uninit_analysis::init_from_phi_def): Adjust. + (uninit_analysis::init_use_preds): Mark the dominating region + before computing control dependences. + +2022-09-07 Richard Sandiford <richard.sandiford@arm.com> + + * config/aarch64/aarch64.md (*mov<SHORT:mode>_aarch64): Extend + w<-w, r<-w and w<-r alternatives to !simd, using 32-bit moves + in that case. Extend w<-r to w<-Z. + (*mov<HFBF:mode>_aarch64): Likewise, but with Y instead of Z. + (*movti_aarch64): Use an FMOV from XZR for w<-Z if MOVI is not + available. + (define_split): Do not apply the floating-point immediate-to-register + split to zeros, even if MOVI is not available. + +2022-09-07 Richard Sandiford <richard.sandiford@arm.com> + + * config/aarch64/aarch64.cc (aarch64_conditional_register_usage): + Disallow use of FPRs in register asms for !TARGET_FLOAT. + +2022-09-07 Lulu Cheng <chenglulu@loongson.cn> + + PR target/106828 + * config/loongarch/loongarch.cc (loongarch_asan_shadow_offset): New. + (TARGET_ASAN_SHADOW_OFFSET): New. + +2022-09-07 Jakub Jelinek <jakub@redhat.com> + + * doc/invoke.texi (-Wno-unicode): Document. + +2022-09-07 Jiufu Guo <guojiufu@linux.ibm.com> + + * config/rs6000/rs6000.md (const_scalar_int splitter): Remove. + +2022-09-07 Jiufu Guo <guojiufu@linux.ibm.com> + + * config/rs6000/rs6000.md: (constant splitters): Use "(pc)" as the + replacements. + +2022-09-07 liuhongt <hongtao.liu@intel.com> + + PR tree-optimization/103144 + * tree-vect-loop.cc (vect_is_nonlinear_iv_evolution): New function. + (vect_analyze_scalar_cycles_1): Detect nonlinear iv by upper function. + (vect_create_nonlinear_iv_init): New function. + (vect_peel_nonlinear_iv_init): Ditto. + (vect_create_nonlinear_iv_step): Ditto + (vect_create_nonlinear_iv_vec_step): Ditto + (vect_update_nonlinear_iv): Ditto + (vectorizable_nonlinear_induction): Ditto. + (vectorizable_induction): Call + vectorizable_nonlinear_induction when induction_type is not + vect_step_op_add. + * tree-vect-loop-manip.cc (vect_update_ivs_after_vectorizer): + Update nonlinear iv for epilogue loop. + * tree-vectorizer.h (enum vect_induction_op_type): New enum. + (STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE): New Macro. + +2022-09-06 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106754 + * gimple-predicate-analysis.cc (compute_control_dep_chain_pdom): + New function, split out from compute_control_dep_chain. Handle + loop-exit like conditions here by pushing to the control vector. + (compute_control_dep_chain): Adjust and streamline dumping. + In the wrapper perform a post-dominator walk as well. + (uninit_analysis::init_use_preds): Remove premature early exit. + +2022-09-06 Max Filippov <jcmvbkbc@gmail.com> + + * config/xtensa/linux.h (LINK_SPEC): Add static-pie. + +2022-09-06 Aldy Hernandez <aldyh@redhat.com> + + * range-op-float.cc (build_le): Handle NANs and going past infinity. + (build_lt): Same. + (build_ge): Same. + (build_gt): Same. + (foperator_lt::op1_range): Avoid adjustments to range if build_* + returned false. + (foperator_lt::op2_range): Same. + (foperator_le::op1_range): Same. + (foperator_le::op2_range): Same. + (foperator_gt::op1_range): Same. + (foperator_gt::op2_range): Same. + +2022-09-06 Richard Biener <rguenther@suse.de> + + * gimple-predicate-analysis.cc (compute_control_dep_chain): + Add output flag to indicate whether we possibly have dropped + any chains. Return whether the info is complete from the + wrapping overload. + (uninit_analysis::init_use_preds): Adjust accordingly, with + a workaround for PR106754. + (uninit_analysis::init_from_phi_def): Properly guard the + case where we complete an empty chain. + +2022-09-06 Jan-Benedict Glaw <jbglaw@lug-owl.de> + + * config/msp430/msp430.cc (msp430_single_op_cost): Document unused argument. + +2022-09-06 Prathamesh Kulkarni <prathamesh.kulkarni@linaro.org> + + * tree-ssa-forwprop.cc (simplify_permutation): Set res_type to a vector + type with same element type as arg0, and length as op2. + +2022-09-06 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106844 + * gimple-predicate-analysis.cc (compute_control_dep_chain): + Return whether we found a chain. + +2022-09-06 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106841 + * tree-vect-slp.cc (vect_detect_hybrid_slp): Also process + scatter/gather offset. + +2022-09-06 Jan-Benedict Glaw <jbglaw@lug-owl.de> + + * config/bpf/bpf.h (REGNO_REG_CLASS): Reference arguments as (void). + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + * gimple.h (enum gf_mask): Add GF_OMP_ORDERED_STANDALONE enumerator. + (gimple_omp_subcode): Use GIMPLE_OMP_ORDERED instead of + GIMPLE_OMP_TEAMS as upper bound. + (gimple_omp_ordered_standalone_p, gimple_omp_ordered_standalone): New + inline functions. + * gimplify.cc (find_standalone_omp_ordered): Look for OMP_ORDERED with + NULL OMP_ORDERED_BODY rather than with OMP_DOACROSS clause. + (gimplify_expr): Call gimple_omp_ordered_standalone for OMP_ORDERED + with NULL OMP_ORDERED_BODY. + * omp-low.cc (check_omp_nesting_restrictions): Use + gimple_omp_ordered_standalone_p test instead of + omp_find_clause (..., OMP_CLAUSE_DOACROSS). + (lower_omp_ordered): Likewise. + * omp-expand.cc (expand_omp, build_omp_regions_1, + omp_make_gimple_edges): Likewise. + +2022-09-06 Xianmiao Qu <cooper.qu@linux.alibaba.com> + + * config/csky/csky.md (cskyv2_addcc): Fix missing operand. + (cskyv2_addcc_invert): Likewise. + +2022-09-06 Jose E. Marchesi <jose.marchesi@oracle.com> + + * config/bpf/bpf.cc (bpf_expand_prologue): Remove unused automatic + `insn'. + (bpf_expand_epilogue): Likewise. + +2022-09-06 liuhongt <hongtao.liu@intel.com> + + * config/i386/i386-builtin.def (IX86_BUILTIN_CVTPS2PH512): + Map to CODE_FOR_avx512f_vcvtps2ph512_mask_sae. + * config/i386/sse.md (<mask_codefor>avx512f_vcvtps2ph512<mask_name>): Extend to .. + (<mask_codefor>avx512f_vcvtps2ph512<mask_name><round_saeonly_name>): .. this. + (avx512f_vcvtps2ph512_mask_sae): New expander + 2022-09-05 Aldy Hernandez <aldyh@redhat.com> * gimple-range-fold.cc diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 80e4d81..eaf5982 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20220906 +20220912 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index d3b66b7..a4689d5 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -1262,6 +1262,7 @@ ANALYZER_OBJS = \ analyzer/engine.o \ analyzer/feasible-graph.o \ analyzer/function-set.o \ + analyzer/known-function-manager.o \ analyzer/pending-diagnostic.o \ analyzer/program-point.o \ analyzer/program-state.o \ diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 80e856d..b1fbd1e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,435 @@ +2022-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.cc (gnat_to_gnu_param): Set DECL_ARTIFICIAL. + +2022-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (At_End_Proc_to_gnu): Use the End_Label of + the child Handled_Statement_Sequence for body nodes. + (set_end_locus_from_node): Minor tweaks. + +2022-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (Full_View_Of_Private_Constant): New + function returning the Full_View of a private constant, after + looking through a chain of renamings, if any. + (Identifier_to_gnu): Call it on the entity. Small cleanup. + +2022-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/utils.cc (gnat_pushdecl): Preserve named + TYPE_DECLs consistently for all kind of pointer types. + +2022-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/trans.cc (gnat_to_gnu) <N_Op_Divide>: Report a + violation of No_Dependence on System.GCC if the result type is + larger than a word. + <N_Op_Shift>: Likewise. + <N_Op_Mod>: Likewise. + <N_Op_Rem>: Likewise. + (convert_with_check): Report a violation of No_Dependence on + System.GCC for a conversion between an integer type larger than + a word and a floating-point type. + +2022-09-06 Steve Baird <baird@adacore.com> + + * sem_ch9.adb + (Allows_Lock_Free_Implementation): Return False if + Support_Atomic_Primitives is False. + +2022-09-06 Steve Baird <baird@adacore.com> + + * debug.adb: Remove comment regarding the -gnatd9 switch. + * doc/gnat_rm/implementation_defined_attributes.rst: Remove all + mention of the Lock_Free attribute. + * gnat_rm.texi, gnat_ugn.texi: Regenerate. + * exp_attr.adb, sem_attr.adb: Remove all mention of the former + Attribute_Lock_Free enumeration element of the Attribute_Id type. + * sem_ch9.adb + (Allows_Lock_Free_Implementation): Remove the Debug_Flag_9 test. + Return False in the case of a protected function whose result type + requires use of the secondary stack. + (Satisfies_Lock_Free_Requirements): This functions checks for + certain constructs and returns False if one is found. In the case + of a protected function, there is no need to check to see if the + protected object is being modified. So it is ok to omit *some* + checks in the case of a protected function. But other checks which + are required (e.g., the test for a reference to a variable that is + not part of the protected object) were being incorrectly omitted. + This could result in accepting "Lock_Free => True" aspect + specifications that should be rejected. + * snames.adb-tmpl: Name_Lock_Free no longer requires special + treatment in Get_Pragma_Id or Is_Pragma_Name (because it is no + longer an attribute name). + * snames.ads-tmpl: Move the declaration of Name_Lock_Free to + reflect the fact that it is no longer the name of an attribute. + Delete Attribute_Lock_Free from the Attribute_Id enumeration type. + +2022-09-06 Steve Baird <baird@adacore.com> + + * libgnat/a-coorse.ads: Restore Aggregate aspect specification for + type Set. + +2022-09-06 Marc Poulhiès <poulhies@adacore.com> + + * exp_util.adb (Build_Allocate_Deallocate_Proc): Add + Alignment_Param in the formal list for calls to SS_Allocate. + +2022-09-06 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Process_Formals): Preserve Has_Private_View flag while + rewriting formal into actual parameters. + +2022-09-06 Javier Miranda <miranda@adacore.com> + + * debug.adb + (Debug_Flag_Underscore_X): Switch added temporarily to allow + disabling extra formal checks. + * exp_attr.adb + (Expand_N_Attribute_Reference [access types]): Add extra formals + to the subprogram referenced in the prefix of 'Unchecked_Access, + 'Unrestricted_Access or 'Access; required to check that its extra + formals match the extra formals of the corresponding subprogram + type. + * exp_ch3.adb + (Stream_Operation_OK): Declaration moved to the public part of the + package. + (Validate_Tagged_Type_Extra_Formals): New subprogram. + (Expand_Freeze_Record_Type): Improve the code that takes care of + adding the extra formals of dispatching primitives; extended to + add also the extra formals to renamings of dispatching primitives. + * exp_ch3.ads + (Stream_Operation_OK): Declaration moved from the package body. + * exp_ch6.adb + (Has_BIP_Extra_Formal): Subprogram declaration moved to the public + part of the package. In addition, a parameter has been added to + disable an assertion that requires its use with frozen entities. + (Expand_Call_Helper): Enforce assertion checking extra formals on + thunks. + (Is_Build_In_Place_Function): Return False for entities with + foreign convention. + (Make_Build_In_Place_Call_In_Object_Declaration): Occurrences of + Is_Return_Object replaced by the local variable + Is_OK_Return_Object that evaluates to False for scopes with + foreign convention. + (Might_Have_Tasks): Fix check of class-wide limited record types. + (Needs_BIP_Task_Actuals): Remove assertion to allow calling this + function in more contexts; in addition it returns False for + functions returning objects with foreign convention. + (Needs_BIP_Finalization_Master): Likewise. + (Needs_BIP_Alloc_Form): Likewise. + * exp_ch6.ads + (Stream_Operation_OK): Declaration moved from the package body. In + addition, a parameter has been added to disable assertion that + requires its use with frozen entities. + * freeze.adb + (Check_Itype): Add extra formals to anonymous access subprogram + itypes. + (Freeze_Expression): Improve code that disables the addition of + extra formals to functions with foreign convention. + (Check_Extra_Formals): Moved to package Sem_Ch6 as + Extra_Formals_OK. + (Freeze_Subprogram): Add extra formals to non-dispatching + subprograms. + * sem_ch3.adb + (Access_Subprogram_Declaration): Defer the addition of extra + formals to the freezing point so that we know the convention. + (Check_Anonymous_Access_Component): Likewise. + (Derive_Subprogram): Fix documentation. + * sem_ch6.adb + (Check_Anonymous_Return): Fix check of access to class-wide + limited record types. + (Check_Untagged_Equality): Placed in alphabetical order. + (Extra_Formals_OK): Subprogram moved from freeze.adb. + (Extra_Formals_Match_OK): New subprogram. + (Has_BIP_Formals): New subprogram. + (Has_Extra_Formals): New subprograms. + (Needs_Accessibility_Check_Extra): New subprogram. + (Needs_Constrained_Extra): New subprogram. + (Parent_Subprogram): New subprogram. + (Add_Extra_Formal): Minor code cleanup. + (Create_Extra_Formals): Enforce matching extra formals on + overridden and aliased entities. + (Has_Reliable_Extra_Formals): New subprogram. + * sem_ch6.ads + (Extra_Formals_OK): Subprogram moved from freeze.adb. + (Extra_Formals_Match_OK): New subprogram. + * sem_eval.adb + (Compile_Time_Known_Value): Improve predicate to avoid assertion + failure; found working on this ticket; this change does not affect + the behavior of the compiler because this subprogram has an + exception handler that returns False when the assertion fails. + * sem_util.adb + (Needs_Result_Accessibility_Level): Do not return False for + dispatching operations compiled with Ada_Version < 2012 since they + they may be overridden by primitives compiled with Ada_Version >= + Ada_2012. + +2022-09-06 Arnaud Charlet <charlet@adacore.com> + + * exp_ch4.adb (Expand_N_If_Expression): Disable optimization + for LLVM. + +2022-09-06 Javier Miranda <miranda@adacore.com> + + * sem_prag.adb + (Analyze_Pre_Post_Condition_In_Decl_Part): Improve check to report + an error in non-legal class-wide conditions. + +2022-09-06 Steve Baird <baird@adacore.com> + + * libgnat/a-strsup.adb, libgnat/a-stwisu.adb, libgnat/a-stzsup.adb + (Super_Slice function and procedure): fix slice length computation. + +2022-09-06 Steve Baird <baird@adacore.com> + + * doc/gnat_ugn/building_executable_programs_with_gnat.rst: + Improve -gnatVa, -gnatVc, -gnatVd, -gnatVe, -gnatVf, -gnatVo, + -gnatVp, -gnatVr, and -gnatVs switch descriptions. + * gnat_ugn.texi: Regenerate. + +2022-09-06 Justin Squirek <squirek@adacore.com> + + * exp_unst.adb + (Visit_Node): Add N_Block_Statement to the enclosing construct + case since they can now have "At end" procedures. Also, recognize + calls from "At end" procedures when recording subprograms. + +2022-09-06 Piotr Trojanek <trojanek@adacore.com> + + * inline.adb (Replace_Formal): Fix name of the referenced routine. + +2022-09-06 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Old]): + Remove unnecessary local constant that was shadowing another + constant with the same initial value. + +2022-09-06 Julien Bortolussi <bortolussi@adacore.com> + + * libgnat/a-cforse.ads (Replace): Fix the postcondition. + +2022-09-06 Steve Baird <baird@adacore.com> + + * exp_attr.adb + (Attribute_Valid): Ensure that PBtyp is initialized to a value for + which Is_Scalar_Type is True. + * checks.adb + (Determine_Range): Call Implemention_Base_Type instead of + Base_Type in order to ensure that result is suitable for passing + to Enum_Pos_To_Rep. + +2022-09-06 Bob Duff <duff@adacore.com> + Eric Botcazou <ebotcazou@adacore.com> + + * gen_il-fields.ads + (First_Real_Statement): Remove this field. + * gen_il-gen-gen_nodes.adb: Remove the First_Real_Statement field. + Add the At_End_Proc field to nodes that have both Declarations and + HSS. + * sinfo.ads + (At_End_Proc): Document new semantics. + (First_Real_Statement): Remove comment. + * exp_ch11.adb + (Expand_N_Handled_Sequence_Of_Statements): Remove + First_Real_Statement. + * exp_ch7.adb + (Build_Cleanup_Statements): Remove "Historical note"; it doesn't + seem useful, and we have revision history. + (Create_Finalizer): Insert the finalizer later, typically in the + statement list, in some cases. + (Build_Finalizer_Call): Attach the "at end" handler to the parent + of the HSS node in most cases, so it applies to declarations. + (Expand_Cleanup_Actions): Remove Wrap_HSS_In_Block and the call to + it. Remove the code that moves declarations. Remove some redundant + code. + * exp_ch9.adb + (Build_Protected_Entry): Copy the At_End_Proc. + (Build_Protected_Subprogram_Body): Reverse the sense of Exc_Safe, + to avoid double negatives. Remove "Historical note" as in + exp_ch7.adb. + (Build_Unprotected_Subprogram_Body): Copy the At_End_Proc from the + protected version. + (Expand_N_Conditional_Entry_Call): Use First (Statements(...)) + instead of First_Real_Statement(...). + (Expand_N_Task_Body): Put the Abort_Undefer call at the beginning + of the declarations, rather than in the HSS. Use First + (Statements(...)) instead of First_Real_Statement(...). Copy the + At_End_Proc. + * inline.adb + (Has_Initialized_Type): Return False if the declaration does not + come from source. + * libgnarl/s-tpoben.ads + (Lock_Entries, Lock_Entries_With_Status): Document when these + things raise Program_Error. It's not clear that + Lock_Entries_With_Status ought to be raising exceptions, but at + least it's documented now. + * sem.ads: Minor comment fixes. + * sem_ch6.adb + (Analyze_Subprogram_Body_Helper): Use First (Statements(...)) + instead of First_Real_Statement(...). + (Analyze_Null_Procedure): Minor comment fix. + * sem_util.adb + (Might_Raise): Return True for N_Raise_Expression. Adjust the part + about exceptions generated by the back end to match the reality of + what the back end generates. + (Update_First_Real_Statement): Remove. + * sem_util.ads: Remove First_Real_Statement from comment. + * sinfo-utils.ads + (First_Real_Statement): New function that always returns Empty. + This should be removed once gnat-llvm and codepeer have been + updated to not refer to First_Real_Statement. + * sprint.adb + (Sprint_At_End_Proc): Deal with printing At_End_Proc. + * sem_prag.adb: Minor comment fixes. + * gcc-interface/trans.cc (At_End_Proc_to_gnu): New function. + (Subprogram_Body_to_gnu): Call it to handle an At_End_Proc. + (Handled_Sequence_Of_Statements_to_gnu): Likewise. Remove the + support for First_Real_Statement and clean up the rest. + (Exception_Handler_to_gnu): Do not push binding levels. + (Compilation_Unit_to_gnu): Adjust call to process_decls. + (gnat_to_gnu) <N_Package_Specification>: Likewise. <N_Entry_Body>: + Likewise. <N_Freeze_Entity>: Likewise. <N_Block_Statement>: + Likewise and call At_End_Proc_to_gnu to handle an At_End_Proc. + <N_Package_Body>: Likewise. + (process_decls): Remove GNAT_END_LIST parameter and adjust + recursive calls. + +2022-09-06 Steve Baird <baird@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst: Document new + temporary rule that a "when others =>" case choice must be given + when casing on a composite selector. + * gnat_rm.texi: Regenerate. + +2022-09-06 Steve Baird <baird@adacore.com> + + * sem_case.adb: Define a new Boolean constant, + Simplified_Composite_Coverage_Rules, initialized to True. Setting + this constant to True has two effects: 1- Representative value + sets are not fully initialized - this is done to avoid capacity + problems, as well as for performance. 2- In + Check_Case_Pattern_Choices, the only legality check performed is a + check that a "when others =>" choice is present. + +2022-09-06 Piotr Trojanek <trojanek@adacore.com> + + * sem_ch13.adb (Analyze_Aspect_Relaxed_Initialization): Fix error + template. + +2022-09-06 Steve Baird <baird@adacore.com> + + * exp_attr.adb + (Make_Range_Test): In determining which subtype's First and Last + attributes are to be queried as part of a range test, call + Validated_View in order to get a scalar (as opposed to private) + subtype. + (Attribute_Valid): In determining whether to perform a signed or + unsigned comparison for a range test, call Validated_View in order + to get a scalar (as opposed to private) type. Also correct a typo + which, by itself, is the source of the problem reported for this + ticket. + +2022-09-06 Steve Baird <baird@adacore.com> + + * sem_ch4.adb + (Analyze_Selected_Component): Define new Boolean-valued function, + Constraint_Has_Unprefixed_Discriminant_Reference, which takes a + subtype that is subject to a discriminant-dependent constraint and + returns True if any of the constraint values are unprefixed + discriminant names. Usually, the Etype of a selected component + node is set to Etype of the component. However, in the case of an + access-to-array component for which this predicate returns True, + we instead use the base type of the Etype of the component. + Normally such problematic discriminant references are addressed by + calling Build_Actual_Subtype_Of_Component, but that doesn't work + if Full_Analyze is False. + +2022-09-06 Piotr Trojanek <trojanek@adacore.com> + + * Makefile.rtl (GNATRTL_NONTASKING_OBJS): Include + System.Value_U_Spec and System.Value_I_Spec units. + +2022-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-powflt.ads (Powfive): New constant array. + * libgnat/s-powlfl.ads (Powfive): Likewise. + (Powfive_100): New constant. + (Powfive_200): Likewise. + (Powfive_300): Likewise. + * libgnat/s-powllf.ads (Powfive): New constant array. + (Powfive_100): New constant. + (Powfive_200): Likewise. + (Powfive_300): Likewise. + * libgnat/s-valflt.ads (Impl): Replace Powten with Powfive and pass + Null_Address for the address of large constants. + * libgnat/s-vallfl.ads (Impl): Replace Powten with Powfive and pass + the address of large constants. + * libgnat/s-valllf.ads (Impl): Likewise. + * libgnat/s-valrea.ads (System.Val_Real): Replace Powten_Address + with Powfive_Address and add Powfive_{1,2,3}00_Address parameters. + * libgnat/s-valrea.adb (Is_Large_Type): New boolean constant. + (Is_Very_Large_Type): Likewise. + (Maxexp32): Change value of 10 to that of 5. + (Maxexp64): Likewise. + (Maxexp80): Likewise. + (Integer_to_Real): Use a combination of tables of powers of 5 and + scaling if the base is 10. + (Large_Powten): Rename into... + (Large_Powfive): ...this. Add support for large constants. + (Large_Powfive): New overloaded function for very large exponents. + +2022-09-06 Piotr Trojanek <trojanek@adacore.com> + + * doc/gnat_rm/implementation_defined_aspects.rst + (Aspect Iterable): Include Last and Previous primitives in + syntactic and semantic description. + * exp_attr.adb + (Expand_N_Attribute_Reference): Don't expect attributes like + Iterable that can only appear in attribute definition clauses. + * sem_ch13.adb + (Analyze_Attribute_Definition_Clause): Prevent crash on + non-aggregate Iterable attribute; improve basic diagnosis of + attribute values. + (Resolve_Iterable_Operation): Improve checks for illegal + primitives in aspect Iterable, e.g. with wrong number of formal + parameters. + (Validate_Iterable_Aspect): Prevent crashes on syntactically + illegal aspect expression. + * sem_util.adb + (Get_Cursor_Type): Fix style. + * gnat_ugn.texi, gnat_rm.texi: Regenerate. + +2022-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * libgnat/s-valuer.ads (System.Value_R): Add Parts formal parameter + as well as Data_Index, Scale_Array and Value_Array types. + (Scan_Raw_Real): Change type of Scale and return type. + (Value_Raw_Real): Likewise. + * libgnat/s-valuer.adb (Round_Extra): Reorder parameters and adjust + recursive call. + (Scan_Decimal_Digits): Reorder parameters, add N parameter and deal + with multi-part scale and value. + (Scan_Integral_Digits): Likewise. + (Scan_Raw_Real): Change type of Scale and return type and deal with + multi-part scale and value. + (Value_Raw_Real): Change type of Scale and return type and tidy up. + * libgnat/s-valued.adb (Impl): Pass 1 as Parts actual parameter. + (Scan_Decimal): Adjust to type changes. + (Value_Decimal): Likewise. + * libgnat/s-valuef.adb (Impl): Pass 1 as Parts actual parameter. + (Scan_Fixed): Adjust to type changes. + (Value_Fixed): Likewise. + * libgnat/s-valrea.adb (Need_Extra): Delete. + (Precision_Limit): Always use the precision of the mantissa. + (Impl): Pass 2 as Parts actual parameter. + (Exact_Log2): New expression function. + (Integer_to_Real): Change type of Scale and Val and deal with a + 2-part integer mantissa. + (Scan_Real): Adjust to type changes. + (Value_Real): Likewise. + 2022-09-05 Martin Liska <mliska@suse.cz> * sigtramp-vxworks-target.h: Rename DBX_REGISTER_NUMBER to diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 00137f2..96306f8 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -110,14 +110,6 @@ GNATRTL_NONTASKING_OBJS= \ a-cbprqu$(objext) \ a-cbsyqu$(objext) \ a-cdlili$(objext) \ - a-cfdlli$(objext) \ - a-cfhama$(objext) \ - a-cfhase$(objext) \ - a-cfidll$(objext) \ - a-cfinve$(objext) \ - a-cfinse$(objext) \ - a-cforma$(objext) \ - a-cforse$(objext) \ a-cgaaso$(objext) \ a-cgarso$(objext) \ a-cgcaso$(objext) \ @@ -144,14 +136,7 @@ GNATRTL_NONTASKING_OBJS= \ a-clrefi$(objext) \ a-coboho$(objext) \ a-cobove$(objext) \ - a-cofove$(objext) \ - a-cofuba$(objext) \ - a-cofuma$(objext) \ - a-cofuse$(objext) \ - a-cofuve$(objext) \ a-cogeso$(objext) \ - a-cohama$(objext) \ - a-cohase$(objext) \ a-cohata$(objext) \ a-coinho$(objext) \ a-coinve$(objext) \ @@ -778,6 +763,7 @@ GNATRTL_NONTASKING_OBJS= \ s-vaenu8$(objext) \ s-vafi32$(objext) \ s-vafi64$(objext) \ + s-vaispe$(objext) \ s-valboo$(objext) \ s-valcha$(objext) \ s-valflt$(objext) \ @@ -796,6 +782,7 @@ GNATRTL_NONTASKING_OBJS= \ s-valuns$(objext) \ s-valuti$(objext) \ s-valwch$(objext) \ + s-vauspe$(objext) \ s-veboop$(objext) \ s-vector$(objext) \ s-vercon$(objext) \ diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index d5877c6..b2fa44d 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -114,6 +114,29 @@ package body Bindgen is -- For CodePeer, introduce a wrapper subprogram which calls the -- user-defined main subprogram. + -- Names and link_names for CUDA device adainit/adafinal procs. + + Device_Subp_Name_Prefix : constant String := "imported_device_"; + Device_Link_Name_Prefix : constant String := "__device_"; + + function Device_Ada_Final_Link_Name return String is + (Device_Link_Name_Prefix & Ada_Final_Name.all); + + function Device_Ada_Final_Subp_Name return String is + (Device_Subp_Name_Prefix & Ada_Final_Name.all); + + function Device_Ada_Init_Link_Name return String is + (Device_Link_Name_Prefix & Ada_Init_Name.all); + + function Device_Ada_Init_Subp_Name return String is + (Device_Subp_Name_Prefix & Ada_Init_Name.all); + + -- Text for aspect specifications (if any) given as part of the + -- Adainit and Adafinal spec declarations. + + function Aspect_Text return String is + (if Enable_CUDA_Device_Expansion then " with CUDA_Global" else ""); + ---------------------------------- -- Interface_State Pragma Table -- ---------------------------------- @@ -501,6 +524,12 @@ package body Bindgen is WBI (" System.Standard_Library.Adafinal;"); end if; + -- perform device (as opposed to host) finalization + if Enable_CUDA_Expansion then + WBI (" pragma CUDA_Execute (" & + Device_Ada_Final_Subp_Name & ", 1, 1);"); + end if; + WBI (" end " & Ada_Final_Name.all & ";"); WBI (""); end Gen_Adafinal; @@ -512,7 +541,6 @@ package body Bindgen is procedure Gen_Adainit (Elab_Order : Unit_Id_Array) is Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority; Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU; - begin -- Declare the access-to-subprogram type used for initialization of -- of __gnat_finalize_library_objects. This is declared at library @@ -1334,6 +1362,13 @@ package body Bindgen is end; end loop; + WBI (" procedure " & Device_Ada_Init_Subp_Name & ";"); + WBI (" pragma Import (C, " & Device_Ada_Init_Subp_Name & + ", Link_Name => """ & Device_Ada_Init_Link_Name & """);"); + WBI (" procedure " & Device_Ada_Final_Subp_Name & ";"); + WBI (" pragma Import (C, " & Device_Ada_Final_Subp_Name & + ", Link_Name => """ & Device_Ada_Final_Link_Name & """);"); + WBI (""); end Gen_CUDA_Defs; @@ -1393,6 +1428,10 @@ package body Bindgen is end loop; WBI (" CUDA_Register_Fat_Binary_End (Fat_Binary_Handle);"); + + -- perform device (as opposed to host) elaboration + WBI (" pragma CUDA_Execute (" & + Device_Ada_Init_Subp_Name & ", 1, 1);"); end Gen_CUDA_Init; -------------------------- @@ -2513,6 +2552,9 @@ package body Bindgen is if Enable_CUDA_Expansion then WBI ("with Interfaces.C;"); WBI ("with Interfaces.C.Strings;"); + + -- with of CUDA.Internal needed for CUDA_Execute pragma expansion + WBI ("with CUDA.Internal;"); end if; Resolve_Binder_Options (Elab_Order); @@ -2602,9 +2644,14 @@ package body Bindgen is end if; WBI (""); - WBI (" procedure " & Ada_Init_Name.all & ";"); - WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ & - Ada_Init_Name.all & """);"); + WBI (" procedure " & Ada_Init_Name.all & Aspect_Text & ";"); + if Enable_CUDA_Device_Expansion then + WBI (" pragma Export (C, " & Ada_Init_Name.all & + ", Link_Name => """ & Device_Ada_Init_Link_Name & """);"); + else + WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ & + Ada_Init_Name.all & """);"); + end if; -- If -a has been specified use pragma Linker_Constructor for the init -- procedure and pragma Linker_Destructor for the final procedure. @@ -2615,9 +2662,15 @@ package body Bindgen is if not Cumulative_Restrictions.Set (No_Finalization) then WBI (""); - WBI (" procedure " & Ada_Final_Name.all & ";"); - WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & - Ada_Final_Name.all & """);"); + WBI (" procedure " & Ada_Final_Name.all & Aspect_Text & ";"); + + if Enable_CUDA_Device_Expansion then + WBI (" pragma Export (C, " & Ada_Final_Name.all & + ", Link_Name => """ & Device_Ada_Final_Link_Name & """);"); + else + WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & + Ada_Final_Name.all & """);"); + end if; if Use_Pragma_Linker_Constructor then WBI (" pragma Linker_Destructor (" & Ada_Final_Name.all & ");"); diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 22577c8..8fa16b8 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -5094,7 +5094,8 @@ package body Checks is -- Don't deal with enumerated types with non-standard representation or else (Is_Enumeration_Type (Typ) - and then Present (Enum_Pos_To_Rep (Base_Type (Typ)))) + and then Present (Enum_Pos_To_Rep + (Implementation_Base_Type (Typ)))) -- Ignore type for which an error has been posted, since range in -- this case may well be a bogosity deriving from the error. Also @@ -9950,8 +9951,8 @@ package body Checks is -- Typ'Length /= Exp'Length function Length_Mismatch_Info_Message - (Left_Element_Count : Uint; - Right_Element_Count : Uint) return String; + (Left_Element_Count : Unat; + Right_Element_Count : Unat) return String; -- Returns a message indicating how many elements were expected -- (Left_Element_Count) and how many were found (Right_Element_Count). @@ -10149,14 +10150,14 @@ package body Checks is ---------------------------------- function Length_Mismatch_Info_Message - (Left_Element_Count : Uint; - Right_Element_Count : Uint) return String + (Left_Element_Count : Unat; + Right_Element_Count : Unat) return String is - function Plural_Vs_Singular_Ending (Count : Uint) return String; + function Plural_Vs_Singular_Ending (Count : Unat) return String; -- Returns an empty string if Count is 1; otherwise returns "s" - function Plural_Vs_Singular_Ending (Count : Uint) return String is + function Plural_Vs_Singular_Ending (Count : Unat) return String is begin if Count = 1 then return ""; @@ -10166,12 +10167,19 @@ package body Checks is end Plural_Vs_Singular_Ending; begin - return "expected " & UI_Image (Left_Element_Count) + return "expected " + & UI_Image (Left_Element_Count, Format => Decimal) & " element" & Plural_Vs_Singular_Ending (Left_Element_Count) - & "; found " & UI_Image (Right_Element_Count) + & "; found " + & UI_Image (Right_Element_Count, Format => Decimal) & " element" & Plural_Vs_Singular_Ending (Right_Element_Count); + -- "Format => Decimal" above is needed because otherwise UI_Image + -- can sometimes return a hexadecimal number 16#...#, but "#" means + -- something special to Errout. A previous version used the default + -- Auto, which was essentially the same bug as documented here: + -- https://xkcd.com/327/ . end Length_Mismatch_Info_Message; ----------------- @@ -10370,14 +10378,14 @@ package body Checks is if L_Length > R_Length then Add_Check (Compile_Time_Constraint_Error - (Wnode, "too few elements for}??", T_Typ, + (Wnode, "too few elements for}!!??", T_Typ, Extra_Msg => Length_Mismatch_Info_Message (L_Length, R_Length))); elsif L_Length < R_Length then Add_Check (Compile_Time_Constraint_Error - (Wnode, "too many elements for}??", T_Typ, + (Wnode, "too many elements for}!!??", T_Typ, Extra_Msg => Length_Mismatch_Info_Message (L_Length, R_Length))); end if; diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 1081b98..34db67a 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -68,6 +68,19 @@ package body Contracts is -- -- Part_Of + procedure Build_Subprogram_Contract_Wrapper + (Body_Id : Entity_Id; + Stmts : List_Id; + Decls : List_Id; + Result : Entity_Id); + -- Generate a wrapper for a given subprogram body when the expansion of + -- postconditions require it by moving its declarations and statements + -- into a locally declared subprogram _Wrapped_Statements. + + -- Postcondition and precondition checks then get inserted in place of + -- the original statements and declarations along with a call to + -- _Wrapped_Statements. + procedure Check_Class_Condition (Cond : Node_Id; Subp : Entity_Id; @@ -78,6 +91,10 @@ package body Contracts is -- In SPARK_Mode, an inherited operation that is not overridden but has -- inherited modified conditions pre/postconditions is illegal. + function Is_Prologue_Renaming (Decl : Node_Id) return Boolean; + -- Determine whether arbitrary declaration Decl denotes a renaming of + -- a discriminant or protection field _object. + procedure Check_Type_Or_Object_External_Properties (Type_Or_Obj_Id : Entity_Id); -- Perform checking of external properties pragmas that is common to both @@ -488,6 +505,45 @@ package body Contracts is end loop; end Analyze_Contracts; + ------------------------------------- + -- Analyze_Pragmas_In_Declarations -- + ------------------------------------- + + procedure Analyze_Pragmas_In_Declarations (Body_Id : Entity_Id) is + Curr_Decl : Node_Id; + + begin + -- Move through the body's declarations analyzing all pragmas which + -- appear at the top of the declarations. + + Curr_Decl := First (Declarations (Unit_Declaration_Node (Body_Id))); + while Present (Curr_Decl) loop + + if Nkind (Curr_Decl) = N_Pragma then + + if Pragma_Significant_To_Subprograms + (Get_Pragma_Id (Curr_Decl)) + then + Analyze (Curr_Decl); + end if; + + -- Skip the renamings of discriminants and protection fields + + elsif Is_Prologue_Renaming (Curr_Decl) then + null; + + -- We have reached something which is not a pragma so we can be sure + -- there are no more contracts or pragmas which need to be taken into + -- account. + + else + exit; + end if; + + Next (Curr_Decl); + end loop; + end Analyze_Pragmas_In_Declarations; + ----------------------------------------------- -- Analyze_Entry_Or_Subprogram_Body_Contract -- ----------------------------------------------- @@ -644,7 +700,7 @@ package body Contracts is else declare - Bod : Node_Id; + Bod : Node_Id := Empty; Freeze_Types : Boolean := False; begin @@ -1263,6 +1319,18 @@ package body Contracts is if Present (Items) then if Analyzed (Items) then return; + + -- Do not analyze the contract of the internal package + -- created to check conformance of an actual package. + -- Such an internal package is removed from the tree after + -- legality checks are completed, and it does not contain + -- the declarations of all local entities of the generic. + + elsif Is_Internal (Pack_Id) + and then Is_Generic_Instance (Pack_Id) + then + return; + else Set_Analyzed (Items); end if; @@ -1499,6 +1567,491 @@ package body Contracts is (Type_Or_Obj_Id => Type_Id); end Analyze_Type_Contract; + --------------------------------------- + -- Build_Subprogram_Contract_Wrapper -- + --------------------------------------- + + procedure Build_Subprogram_Contract_Wrapper + (Body_Id : Entity_Id; + Stmts : List_Id; + Decls : List_Id; + Result : Entity_Id) + is + Body_Decl : constant Entity_Id := Unit_Declaration_Node (Body_Id); + Loc : constant Source_Ptr := Sloc (Body_Decl); + Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); + Subp_Id : Entity_Id; + Ret_Type : Entity_Id; + + Wrapper_Id : Entity_Id; + Wrapper_Body : Node_Id; + Wrapper_Spec : Node_Id; + + begin + -- When there are no postcondition statements we do not need to + -- generate a wrapper. + + if No (Stmts) then + return; + end if; + + -- Obtain the related subprogram id from the body id. + + if Present (Spec_Id) then + Subp_Id := Spec_Id; + else + Subp_Id := Body_Id; + end if; + Ret_Type := Etype (Subp_Id); + + -- Generate the contracts wrapper by moving the original declarations + -- and statements within a local subprogram, calling it and possibly + -- preserving the result for the purpose of evaluating postconditions, + -- contracts, type invariants, etc. + + -- In the case of a function, generate: + -- + -- function Original_Func (X : in out Integer) return Typ is + -- <prologue renamings> + -- <preconditions> + -- + -- function _Wrapped_Statements return Typ is + -- <original declarations> + -- begin + -- <original statements> + -- end; + -- + -- begin + -- declare + -- type Axx is access all Typ; + -- Rxx : constant Axx := _Wrapped_Statements'reference; + -- Result_Obj : Typ renames Rxx.all; + -- + -- begin + -- <postconditions statments> + -- return Rxx.all; + -- end; + -- end; + -- + -- This sequence is recognized by Expand_Simple_Function_Return as a + -- tail call, in other words equivalent to "return _Wrapped_Statements;" + -- and thus the copy to the anonymous return object is elided, including + -- a pair of calls to Adjust/Finalize for types requiring finalization. + + -- Note that an extended return statement does not yield the same result + -- because the copy of the return object is not elided by GNAT for now. + + -- Or, in the case of a procedure: + -- + -- procedure Original_Proc (X : in out Integer) is + -- <prologue renamings> + -- <preconditions> + -- + -- procedure _Wrapped_Statements is + -- <original declarations> + -- begin + -- <original statements> + -- end; + -- + -- begin + -- _Wrapped_Statements; + -- <postconditions statments> + -- end; + -- + + -- Create Identifier + + Wrapper_Id := Make_Defining_Identifier (Loc, Name_uWrapped_Statements); + Set_Debug_Info_Needed (Wrapper_Id); + Set_Wrapped_Statements (Subp_Id, Wrapper_Id); + + -- Create specification and declaration for the wrapper + + if No (Ret_Type) or else Ret_Type = Standard_Void_Type then + Wrapper_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id); + else + Wrapper_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Result_Definition => New_Occurrence_Of (Ret_Type, Loc)); + end if; + + -- Create the wrapper body using Body_Id's statements and declarations + + Wrapper_Body := + Make_Subprogram_Body (Loc, + Specification => Wrapper_Spec, + Declarations => Declarations (Body_Decl), + Handled_Statement_Sequence => + Relocate_Node (Handled_Statement_Sequence (Body_Decl))); + + Append_To (Decls, Wrapper_Body); + Set_Declarations (Body_Decl, Decls); + Set_Handled_Statement_Sequence (Body_Decl, + Make_Handled_Sequence_Of_Statements (Loc, + End_Label => Make_Identifier (Loc, Chars (Wrapper_Id)))); + + -- Move certain flags which are relevant to the body + + -- Wouldn't a better way be to perform some sort of copy of Body_Decl + -- for Wrapper_Body be less error-prone ??? + + if Was_Expression_Function (Body_Decl) then + Set_Was_Expression_Function (Body_Decl, False); + Set_Was_Expression_Function (Wrapper_Body); + end if; + + Set_Has_Pragma_Inline (Wrapper_Id, Has_Pragma_Inline (Subp_Id)); + Set_Has_Pragma_Inline_Always + (Wrapper_Id, Has_Pragma_Inline_Always (Subp_Id)); + + -- Prepend a call to the wrapper when the subprogram is a procedure + + if No (Ret_Type) or else Ret_Type = Standard_Void_Type then + Prepend_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Wrapper_Id, Loc))); + Set_Statements + (Handled_Statement_Sequence (Body_Decl), Stmts); + + -- Declare a renaming of the result of the call to the wrapper and + -- append a return of the result of the call when the subprogram is + -- a function, after manually removing the side effects. Note that + -- we cannot call Remove_Side_Effects here because nothing has been + -- analyzed yet and we cannot return the renaming itself because + -- Expand_Simple_Function_Return expects an explicit dereference. + + else + declare + A_Id : constant Node_Id := Make_Temporary (Loc, 'A'); + R_Id : constant Node_Id := Make_Temporary (Loc, 'R'); + + begin + Set_Statements (Handled_Statement_Sequence (Body_Decl), New_List ( + Make_Block_Statement (Loc, + + Declarations => New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => A_Id, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Null_Exclusion_Present => True, + Subtype_Indication => + New_Occurrence_Of (Ret_Type, Loc))), + + Make_Object_Declaration (Loc, + Defining_Identifier => R_Id, + Object_Definition => New_Occurrence_Of (A_Id, Loc), + Constant_Present => True, + Expression => + Make_Reference (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Wrapper_Id, Loc)))), + + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Result, + Subtype_Mark => New_Occurrence_Of (Ret_Type, Loc), + Name => + Make_Explicit_Dereference (Loc, + New_Occurrence_Of (R_Id, Loc)))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)))); + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Explicit_Dereference (Loc, + New_Occurrence_Of (R_Id, Loc)))); + + -- It is required for Is_Related_To_Func_Return to return True + -- that the temporary Rxx be related to the expression of the + -- simple return statement built just above. + + Set_Related_Expression (R_Id, Expression (Last (Stmts))); + end; + end if; + end Build_Subprogram_Contract_Wrapper; + + ---------------------------------- + -- Build_Entry_Contract_Wrapper -- + ---------------------------------- + + procedure Build_Entry_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is + Conc_Typ : constant Entity_Id := Scope (E); + Loc : constant Source_Ptr := Sloc (E); + + procedure Add_Discriminant_Renamings + (Obj_Id : Entity_Id; + Decls : List_Id); + -- Add renaming declarations for all discriminants of concurrent type + -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which + -- represents the concurrent object. + + procedure Add_Matching_Formals + (Formals : List_Id; + Actuals : in out List_Id); + -- Add formal parameters that match those of entry E to list Formals. + -- The routine also adds matching actuals for the new formals to list + -- Actuals. + + procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id); + -- Relocate pragma Prag to list To. The routine creates a new list if + -- To does not exist. + + -------------------------------- + -- Add_Discriminant_Renamings -- + -------------------------------- + + procedure Add_Discriminant_Renamings + (Obj_Id : Entity_Id; + Decls : List_Id) + is + Discr : Entity_Id; + Renaming_Decl : Node_Id; + + begin + -- Inspect the discriminants of the concurrent type and generate a + -- renaming for each one. + + if Has_Discriminants (Conc_Typ) then + Discr := First_Discriminant (Conc_Typ); + while Present (Discr) loop + Renaming_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Discr)), + Subtype_Mark => + New_Occurrence_Of (Etype (Discr), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Selector_Name => + Make_Identifier (Loc, Chars (Discr)))); + + Prepend_To (Decls, Renaming_Decl); + + Next_Discriminant (Discr); + end loop; + end if; + end Add_Discriminant_Renamings; + + -------------------------- + -- Add_Matching_Formals -- + -------------------------- + + procedure Add_Matching_Formals + (Formals : List_Id; + Actuals : in out List_Id) + is + Formal : Entity_Id; + New_Formal : Entity_Id; + + begin + -- Inspect the formal parameters of the entry and generate a new + -- matching formal with the same name for the wrapper. A reference + -- to the new formal becomes an actual in the entry call. + + Formal := First_Formal (E); + while Present (Formal) loop + New_Formal := Make_Defining_Identifier (Loc, Chars (Formal)); + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Formal, + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Occurrence_Of (Etype (Formal), Loc))); + + if No (Actuals) then + Actuals := New_List; + end if; + + Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); + Next_Formal (Formal); + end loop; + end Add_Matching_Formals; + + --------------------- + -- Transfer_Pragma -- + --------------------- + + procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is + New_Prag : Node_Id; + + begin + if No (To) then + To := New_List; + end if; + + New_Prag := Relocate_Node (Prag); + + Set_Analyzed (New_Prag, False); + Append (New_Prag, To); + end Transfer_Pragma; + + -- Local variables + + Items : constant Node_Id := Contract (E); + Actuals : List_Id := No_List; + Call : Node_Id; + Call_Nam : Node_Id; + Decls : List_Id := No_List; + Formals : List_Id; + Has_Pragma : Boolean := False; + Index_Id : Entity_Id; + Obj_Id : Entity_Id; + Prag : Node_Id; + Wrapper_Id : Entity_Id; + + -- Start of processing for Build_Entry_Contract_Wrapper + + begin + -- This routine generates a specialized wrapper for a protected or task + -- entry [family] which implements precondition/postcondition semantics. + -- Preconditions and case guards of contract cases are checked before + -- the protected action or rendezvous takes place. + + -- procedure Wrapper + -- (Obj_Id : Conc_Typ; -- concurrent object + -- [Index : Index_Typ;] -- index of entry family + -- [Formal_1 : ...; -- parameters of original entry + -- Formal_N : ...]) + -- is + -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant + -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings + + -- <contracts pragmas> + -- <case guard checks> + + -- begin + -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]); + -- end Wrapper; + + -- Create the wrapper only when the entry has at least one executable + -- contract item such as contract cases, precondition or postcondition. + + if Present (Items) then + + -- Inspect the list of pre/postconditions and transfer all available + -- pragmas to the declarative list of the wrapper. + + Prag := Pre_Post_Conditions (Items); + while Present (Prag) loop + if Pragma_Name_Unmapped (Prag) in Name_Postcondition + | Name_Precondition + and then Is_Checked (Prag) + then + Has_Pragma := True; + Transfer_Pragma (Prag, To => Decls); + end if; + + Prag := Next_Pragma (Prag); + end loop; + + -- Inspect the list of test/contract cases and transfer only contract + -- cases pragmas to the declarative part of the wrapper. + + Prag := Contract_Test_Cases (Items); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Contract_Cases + and then Is_Checked (Prag) + then + Has_Pragma := True; + Transfer_Pragma (Prag, To => Decls); + end if; + + Prag := Next_Pragma (Prag); + end loop; + end if; + + -- The entry lacks executable contract items and a wrapper is not needed + + if not Has_Pragma then + return; + end if; + + -- Create the profile of the wrapper. The first formal parameter is the + -- concurrent object. + + Obj_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Conc_Typ), 'A')); + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Obj_Id, + Out_Present => True, + In_Present => True, + Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc))); + + -- Construct the call to the original entry. The call will be gradually + -- augmented with an optional entry index and extra parameters. + + Call_Nam := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Selector_Name => New_Occurrence_Of (E, Loc)); + + -- When creating a wrapper for an entry family, the second formal is the + -- entry index. + + if Ekind (E) = E_Entry_Family then + Index_Id := Make_Defining_Identifier (Loc, Name_I); + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Index_Id, + Parameter_Type => + New_Occurrence_Of (Entry_Index_Type (E), Loc))); + + -- The call to the original entry becomes an indexed component to + -- accommodate the entry index. + + Call_Nam := + Make_Indexed_Component (Loc, + Prefix => Call_Nam, + Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))); + end if; + + -- Add formal parameters to match those of the entry and build actuals + -- for the entry call. + + Add_Matching_Formals (Formals, Actuals); + + Call := + Make_Procedure_Call_Statement (Loc, + Name => Call_Nam, + Parameter_Associations => Actuals); + + -- Add renaming declarations for the discriminants of the enclosing type + -- as the various contract items may reference them. + + Add_Discriminant_Renamings (Obj_Id, Decls); + + Wrapper_Id := + Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E')); + Set_Contract_Wrapper (E, Wrapper_Id); + Set_Is_Entry_Wrapper (Wrapper_Id); + + -- The wrapper body is analyzed when the enclosing type is frozen + + Append_Freeze_Action (Defining_Entity (Decl), + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => Formals), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call)))); + end Build_Entry_Contract_Wrapper; + --------------------------- -- Check_Class_Condition -- --------------------------- @@ -1804,16 +2357,9 @@ package body Contracts is -- the item denotes a pragma, it is added to the list only when it is -- enabled. - procedure Build_Postconditions_Procedure - (Subp_Id : Entity_Id; - Stmts : List_Id; - Result : Entity_Id); - -- Create the body of procedure _Postconditions which handles various - -- assertion actions on exit from subprogram Subp_Id. Stmts is the list - -- of statements to be checked on exit. Parameter Result is the entity - -- of parameter _Result when Subp_Id denotes a function. - - procedure Process_Contract_Cases (Stmts : in out List_Id); + procedure Process_Contract_Cases + (Stmts : in out List_Id; + Decls : List_Id); -- Process pragma Contract_Cases. This routine prepends items to the -- body declarations and appends items to list Stmts. @@ -1821,7 +2367,7 @@ package body Contracts is -- Collect all [inherited] spec and body postconditions and accumulate -- their pragma Check equivalents in list Stmts. - procedure Process_Preconditions; + procedure Process_Preconditions (Decls : in out List_Id); -- Collect all [inherited] spec and body preconditions and prepend their -- pragma Check equivalents to the declarations of the body. @@ -2309,260 +2855,14 @@ package body Contracts is end if; end Append_Enabled_Item; - ------------------------------------ - -- Build_Postconditions_Procedure -- - ------------------------------------ - - procedure Build_Postconditions_Procedure - (Subp_Id : Entity_Id; - Stmts : List_Id; - Result : Entity_Id) - is - Loc : constant Source_Ptr := Sloc (Body_Decl); - Last_Decl : Node_Id; - Params : List_Id := No_List; - Proc_Bod : Node_Id; - Proc_Decl : Node_Id; - Proc_Id : Entity_Id; - Proc_Spec : Node_Id; - - -- Extra declarations needed to handle interactions between - -- postconditions and finalization. - - Postcond_Enabled_Decl : Node_Id; - Return_Success_Decl : Node_Id; - Result_Obj_Decl : Node_Id; - Result_Obj_Type_Decl : Node_Id; - Result_Obj_Type : Entity_Id; - - -- Start of processing for Build_Postconditions_Procedure - - begin - -- Nothing to do if there are no actions to check on exit - - if No (Stmts) then - return; - end if; - - -- Otherwise, we generate the postcondition procedure and add - -- associated objects and conditions used to coordinate postcondition - -- evaluation with finalization. - - -- Generate: - -- - -- procedure _postconditions (Return_Exp : Result_Typ); - -- - -- -- Result_Obj_Type created when Result_Type is non-elementary - -- [type Result_Obj_Type is access all Result_Typ;] - -- - -- Result_Obj : Result_Obj_Type; - -- - -- Postcond_Enabled : Boolean := True; - -- Return_Success_For_Postcond : Boolean := False; - -- - -- procedure _postconditions (Return_Exp : Result_Typ) is - -- begin - -- if Postcond_Enabled and then Return_Success_For_Postcond then - -- [stmts]; - -- end if; - -- end; - - Proc_Id := Make_Defining_Identifier (Loc, Name_uPostconditions); - Set_Debug_Info_Needed (Proc_Id); - Set_Postconditions_Proc (Subp_Id, Proc_Id); - - -- Mark it inlined to speed up the call - - Set_Is_Inlined (Proc_Id); - - -- Force the front-end inlining of _Postconditions when generating C - -- code, since its body may have references to itypes defined in the - -- enclosing subprogram, which would cause problems for unnesting - -- routines in the absence of inlining. - - if Modify_Tree_For_C then - Set_Has_Pragma_Inline (Proc_Id); - Set_Has_Pragma_Inline_Always (Proc_Id); - end if; - - -- The related subprogram is a function: create the specification of - -- parameter _Result. - - if Present (Result) then - Params := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Result, - Parameter_Type => - New_Occurrence_Of (Etype (Result), Loc))); - end if; - - Proc_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc_Id, - Parameter_Specifications => Params); - - Proc_Decl := Make_Subprogram_Declaration (Loc, Proc_Spec); - - -- Insert _Postconditions before the first source declaration of the - -- body. This ensures that the body will not cause any premature - -- freezing, as it may mention types: - - -- Generate: - -- - -- procedure Proc (Obj : Array_Typ) is - -- procedure _postconditions is - -- begin - -- ... Obj ... - -- end _postconditions; - -- - -- subtype T is Array_Typ (Obj'First (1) .. Obj'Last (1)); - -- begin - - -- In the example above, Obj is of type T but the incorrect placement - -- of _Postconditions will cause a crash in gigi due to an out-of- - -- order reference. The body of _Postconditions must be placed after - -- the declaration of Temp to preserve correct visibility. - - Insert_Before_First_Source_Declaration - (Proc_Decl, Declarations (Body_Decl)); - Analyze (Proc_Decl); - Last_Decl := Proc_Decl; - - -- When Result is present (e.g. the postcondition checks apply to a - -- function) we make a local object to capture the result, so, if - -- needed, we can call the generated postconditions procedure during - -- finalization instead of at the point of return. - - -- Note: The placement of the following declarations before the - -- declaration of the body of the postconditions, but after the - -- declaration of the postconditions spec is deliberate and required - -- since other code within the expander expects them to be located - -- here. Perhaps when more space is available in the tree this will - -- no longer be necessary ??? - - if Present (Result) then - -- Elementary result types mean a copy is cheap and preferred over - -- using pointers. - - if Is_Elementary_Type (Etype (Result)) then - Result_Obj_Type := Etype (Result); - - -- Otherwise, we create a named access type to capture the result - - -- Generate: - -- - -- type Result_Obj_Type is access all [Result_Type]; - - else - Result_Obj_Type := Make_Temporary (Loc, 'R'); - - Result_Obj_Type_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Result_Obj_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => New_Occurrence_Of - (Etype (Result), Loc))); - Insert_After_And_Analyze (Proc_Decl, Result_Obj_Type_Decl); - Last_Decl := Result_Obj_Type_Decl; - end if; - - -- Create the result obj declaration - - -- Generate: - -- - -- Result_Object_For_Postcond : Result_Obj_Type; - - Result_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier - (Loc, Name_uResult_Object_For_Postcond), - Object_Definition => - New_Occurrence_Of - (Result_Obj_Type, Loc)); - Set_No_Initialization (Result_Obj_Decl); - Insert_After_And_Analyze (Last_Decl, Result_Obj_Decl); - Last_Decl := Result_Obj_Decl; - end if; - - -- Build the Postcond_Enabled flag used to delay evaluation of - -- postconditions until finalization has been performed when cleanup - -- actions are present. - - -- NOTE: This flag could be made into a predicate since we should be - -- able at compile time to recognize when finalization and cleanup - -- actions occur, but in practice this is not possible ??? - - -- Generate: - -- - -- Postcond_Enabled : Boolean := True; - - Postcond_Enabled_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier - (Loc, Name_uPostcond_Enabled), - Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => New_Occurrence_Of (Standard_True, Loc)); - Insert_After_And_Analyze (Last_Decl, Postcond_Enabled_Decl); - Last_Decl := Postcond_Enabled_Decl; - - -- Create a flag to indicate that return has been reached - - -- This is necessary for deciding whether to execute _postconditions - -- during finalization. - - -- Generate: - -- - -- Return_Success_For_Postcond : Boolean := False; - - Return_Success_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier - (Loc, Name_uReturn_Success_For_Postcond), - Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => New_Occurrence_Of (Standard_False, Loc)); - Insert_After_And_Analyze (Last_Decl, Return_Success_Decl); - Last_Decl := Return_Success_Decl; - - -- Set an explicit End_Label to override the sloc of the implicit - -- RETURN statement, and prevent it from inheriting the sloc of one - -- the postconditions: this would cause confusing debug info to be - -- produced, interfering with coverage-analysis tools. - - -- NOTE: Coverage-analysis and static-analysis tools rely on the - -- postconditions procedure being free of internally generated code - -- since some of these tools, like CodePeer, treat _postconditions - -- as original source. - - -- Generate: - -- - -- procedure _postconditions is - -- begin - -- [Stmts]; - -- end; - - Proc_Bod := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Proc_Spec), - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - End_Label => Make_Identifier (Loc, Chars (Proc_Id)), - Statements => Stmts)); - Insert_After_And_Analyze (Last_Decl, Proc_Bod); - - end Build_Postconditions_Procedure; - ---------------------------- -- Process_Contract_Cases -- ---------------------------- - procedure Process_Contract_Cases (Stmts : in out List_Id) is + procedure Process_Contract_Cases + (Stmts : in out List_Id; + Decls : List_Id) + is procedure Process_Contract_Cases_For (Subp_Id : Entity_Id); -- Process pragma Contract_Cases for subprogram Subp_Id @@ -2583,14 +2883,14 @@ package body Contracts is Expand_Pragma_Contract_Cases (CCs => Prag, Subp_Id => Subp_Id, - Decls => Declarations (Body_Decl), + Decls => Decls, Stmts => Stmts); elsif Pragma_Name (Prag) = Name_Subprogram_Variant then Expand_Pragma_Subprogram_Variant (Prag => Prag, Subp_Id => Subp_Id, - Body_Decls => Declarations (Body_Decl)); + Body_Decls => Decls); end if; end if; @@ -2599,11 +2899,6 @@ package body Contracts is end if; end Process_Contract_Cases_For; - pragma Unmodified (Stmts); - -- Stmts is passed as IN OUT to signal that the list can be updated, - -- even if the corresponding integer value representing the list does - -- not change. - -- Start of processing for Process_Contract_Cases begin @@ -2829,15 +3124,11 @@ package body Contracts is -- Process_Preconditions -- --------------------------- - procedure Process_Preconditions is + procedure Process_Preconditions (Decls : in out List_Id) is Insert_Node : Node_Id := Empty; -- The insertion node after which all pragma Check equivalents are -- inserted. - function Is_Prologue_Renaming (Decl : Node_Id) return Boolean; - -- Determine whether arbitrary declaration Decl denotes a renaming of - -- a discriminant or protection field _object. - procedure Prepend_To_Decls (Item : Node_Id); -- Prepend a single item to the declarations of the subprogram body @@ -2849,64 +3140,12 @@ package body Contracts is -- Collect all preconditions of subprogram Subp_Id and prepend their -- pragma Check equivalents to the declarations of the body. - -------------------------- - -- Is_Prologue_Renaming -- - -------------------------- - - function Is_Prologue_Renaming (Decl : Node_Id) return Boolean is - Nam : Node_Id; - Obj : Entity_Id; - Pref : Node_Id; - Sel : Node_Id; - - begin - if Nkind (Decl) = N_Object_Renaming_Declaration then - Obj := Defining_Entity (Decl); - Nam := Name (Decl); - - if Nkind (Nam) = N_Selected_Component then - Pref := Prefix (Nam); - Sel := Selector_Name (Nam); - - -- A discriminant renaming appears as - -- Discr : constant ... := Prefix.Discr; - - if Ekind (Obj) = E_Constant - and then Is_Entity_Name (Sel) - and then Present (Entity (Sel)) - and then Ekind (Entity (Sel)) = E_Discriminant - then - return True; - - -- A protection field renaming appears as - -- Prot : ... := _object._object; - - -- A renamed private component is just a component of - -- _object, with an arbitrary name. - - elsif Ekind (Obj) in E_Variable | E_Constant - and then Nkind (Pref) = N_Identifier - and then Chars (Pref) = Name_uObject - and then Nkind (Sel) = N_Identifier - then - return True; - end if; - end if; - end if; - - return False; - end Is_Prologue_Renaming; - ---------------------- -- Prepend_To_Decls -- ---------------------- procedure Prepend_To_Decls (Item : Node_Id) is - Decls : List_Id; - begin - Decls := Declarations (Body_Decl); - -- Ensure that the body has a declarative list if No (Decls) then @@ -2937,14 +3176,8 @@ package body Contracts is else Check_Prag := Build_Pragma_Check_Equivalent (Prag); + Prepend_To_Decls (Check_Prag); - if Present (Insert_Node) then - Insert_After (Insert_Node, Check_Prag); - else - Prepend_To_Decls (Check_Prag); - end if; - - Analyze (Check_Prag); end if; end Prepend_Pragma_To_Decls; @@ -3037,16 +3270,17 @@ package body Contracts is -- Local variables - Decls : constant List_Id := Declarations (Body_Decl); - Decl : Node_Id; + Body_Decls : constant List_Id := Declarations (Body_Decl); + Decl : Node_Id; + Next_Decl : Node_Id; -- Start of processing for Process_Preconditions begin -- Find the proper insertion point for all pragma Check equivalents - if Present (Decls) then - Decl := First (Decls); + if Present (Body_Decls) then + Decl := First (Body_Decls); while Present (Decl) loop -- First source declaration terminates the search, because all @@ -3091,6 +3325,19 @@ package body Contracts is -- <preconditions from body> Process_Preconditions_For (Body_Id); + + -- Move the generated entry-call prologue renamings into the + -- outer declarations for use in the preconditions. + + Decl := First (Body_Decls); + while Present (Decl) and then Present (Insert_Node) loop + Next_Decl := Next (Decl); + Remove (Decl); + Prepend_To_Decls (Decl); + + exit when Decl = Insert_Node; + Decl := Next_Decl; + end loop; end if; if Present (Spec_Id) then @@ -3103,6 +3350,7 @@ package body Contracts is Restore_Scope : Boolean := False; Result : Entity_Id; Stmts : List_Id := No_List; + Decls : List_Id := New_List; Subp_Id : Entity_Id; -- Start of processing for Expand_Subprogram_Contract @@ -3181,8 +3429,22 @@ package body Contracts is -- pragmas to verify the contract assertions of the spec and body in a -- particular order. The order is as follows: - -- function Example (...) return ... is - -- procedure _Postconditions (...) is + -- function Original_Code (...) return ... is + -- <prologue renamings> + -- <inherited preconditions> + -- <preconditions from spec> + -- <preconditions from body> + -- <contract case conditions> + + -- function _Wrapped_Statements (...) return ... is + -- <source declarations> + -- begin + -- <source statements> + -- end _Wrapped_Statements; + + -- begin + -- declare + -- Result : ... renames _Wrapped_Statements; -- begin -- <refined postconditions from body> -- <postconditions from body> @@ -3190,24 +3452,10 @@ package body Contracts is -- <inherited postconditions> -- <contract case consequences> -- <invariant check of function result> - -- <invariant and predicate checks of parameters> - -- end _Postconditions; - - -- <inherited preconditions> - -- <preconditions from spec> - -- <preconditions from body> - -- <contract case conditions> - - -- <source declarations> - -- begin - -- <source statements> - - -- _Preconditions (Result); - -- return Result; - -- end Example; - - -- Routine _Postconditions holds all contract assertions that must be - -- verified on exit from the related subprogram. + -- <invariant and predicate checks of parameters + -- return Result; + -- end; + -- end Original_Code; -- Step 1: augment contracts list with postconditions associated with -- Stable_Properties and Stable_Properties'Class aspects. This must @@ -3222,7 +3470,7 @@ package body Contracts is -- processing of pragma Contract_Cases because the pragma prepends items -- to the body declarations. - Process_Preconditions; + Process_Preconditions (Decls); -- Step 3: Handle all postconditions. This action must come before the -- processing of pragma Contract_Cases because the pragma appends items @@ -3234,16 +3482,26 @@ package body Contracts is -- the processing of invariants and predicates because those append -- items to list Stmts. - Process_Contract_Cases (Stmts); + Process_Contract_Cases (Stmts, Decls); -- Step 5: Apply invariant and predicate checks on a function result and -- all formals. The resulting checks are accumulated in list Stmts. Add_Invariant_And_Predicate_Checks (Subp_Id, Stmts, Result); - -- Step 6: Construct procedure _Postconditions + -- Step 6: Construct subprogram _wrapped_statements + + -- When no statements are present we still need to insert contract + -- related declarations. + + if No (Stmts) then + Prepend_List_To (Declarations (Body_Decl), Decls); - Build_Postconditions_Procedure (Subp_Id, Stmts, Result); + -- Otherwise, we need a wrapper + + else + Build_Subprogram_Contract_Wrapper (Body_Id, Stmts, Decls, Result); + end if; if Restore_Scope then End_Scope; @@ -3448,81 +3706,6 @@ package body Contracts is Freeze_Contracts; end Freeze_Previous_Contracts; - -------------------------- - -- Get_Postcond_Enabled -- - -------------------------- - - function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id is - Decl : Node_Id; - begin - Decl := - Next (Unit_Declaration_Node (Postconditions_Proc (Subp))); - while Present (Decl) loop - - if Nkind (Decl) = N_Object_Declaration - and then Chars (Defining_Identifier (Decl)) - = Name_uPostcond_Enabled - then - return Defining_Identifier (Decl); - end if; - - Next (Decl); - end loop; - - return Empty; - end Get_Postcond_Enabled; - - ------------------------------------ - -- Get_Result_Object_For_Postcond -- - ------------------------------------ - - function Get_Result_Object_For_Postcond - (Subp : Entity_Id) return Entity_Id - is - Decl : Node_Id; - begin - Decl := - Next (Unit_Declaration_Node (Postconditions_Proc (Subp))); - while Present (Decl) loop - - if Nkind (Decl) = N_Object_Declaration - and then Chars (Defining_Identifier (Decl)) - = Name_uResult_Object_For_Postcond - then - return Defining_Identifier (Decl); - end if; - - Next (Decl); - end loop; - - return Empty; - end Get_Result_Object_For_Postcond; - - ------------------------------------- - -- Get_Return_Success_For_Postcond -- - ------------------------------------- - - function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Entity_Id - is - Decl : Node_Id; - begin - Decl := - Next (Unit_Declaration_Node (Postconditions_Proc (Subp))); - while Present (Decl) loop - - if Nkind (Decl) = N_Object_Declaration - and then Chars (Defining_Identifier (Decl)) - = Name_uReturn_Success_For_Postcond - then - return Defining_Identifier (Decl); - end if; - - Next (Decl); - end loop; - - return Empty; - end Get_Return_Success_For_Postcond; - --------------------------------- -- Inherit_Subprogram_Contract -- --------------------------------- @@ -3617,6 +3800,65 @@ package body Contracts is end if; end Instantiate_Subprogram_Contract; + -------------------------- + -- Is_Prologue_Renaming -- + -------------------------- + + -- This should be turned into a flag and set during the expansion of + -- task and protected types when the renamings get generated ??? + + function Is_Prologue_Renaming (Decl : Node_Id) return Boolean is + Nam : Node_Id; + Obj : Entity_Id; + Pref : Node_Id; + Sel : Node_Id; + + begin + if Nkind (Decl) = N_Object_Renaming_Declaration + and then not Comes_From_Source (Decl) + then + Obj := Defining_Entity (Decl); + Nam := Name (Decl); + + if Nkind (Nam) = N_Selected_Component then + -- Analyze the renaming declaration so we can further examine it + + if not Analyzed (Decl) then + Analyze (Decl); + end if; + + Pref := Prefix (Nam); + Sel := Selector_Name (Nam); + + -- A discriminant renaming appears as + -- Discr : constant ... := Prefix.Discr; + + if Ekind (Obj) = E_Constant + and then Is_Entity_Name (Sel) + and then Present (Entity (Sel)) + and then Ekind (Entity (Sel)) = E_Discriminant + then + return True; + + -- A protection field renaming appears as + -- Prot : ... := _object._object; + + -- A renamed private component is just a component of + -- _object, with an arbitrary name. + + elsif Ekind (Obj) in E_Variable | E_Constant + and then Nkind (Pref) = N_Identifier + and then Chars (Pref) = Name_uObject + and then Nkind (Sel) = N_Identifier + then + return True; + end if; + end if; + end if; + + return False; + end Is_Prologue_Renaming; + ----------------------------------- -- Make_Class_Precondition_Subps -- ----------------------------------- diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads index 5178373..bde32ff 100644 --- a/gcc/ada/contracts.ads +++ b/gcc/ada/contracts.ads @@ -64,6 +64,16 @@ package Contracts is procedure Analyze_Contracts (L : List_Id); -- Analyze the contracts of all eligible constructs found in list L + procedure Analyze_Pragmas_In_Declarations (Body_Id : Entity_Id); + -- Perform early analysis of pragmas at the top of a given subprogram's + -- declarations. + -- + -- The purpose of this is to analyze contract-related pragmas for later + -- processing, but also to handle other such pragmas before these + -- declarations get moved to an internal wrapper as part of contract + -- expansion. For example, pragmas Inline, Ghost, Volatile all need to + -- apply directly to the subprogram and not be moved to a wrapper. + procedure Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id : Entity_Id); -- Analyze all delayed pragmas chained on the contract of entry or -- subprogram body Body_Id as if they appeared at the end of a declarative @@ -177,6 +187,17 @@ package Contracts is -- Depends -- Global + procedure Build_Entry_Contract_Wrapper (E : Entity_Id; Decl : Node_Id); + -- Build the body of a wrapper procedure for an entry or entry family that + -- has contract cases, preconditions, or postconditions, and add it to the + -- freeze actions of the related synchronized type. + -- + -- The body first verifies the preconditions and case guards of the + -- contract cases, then invokes the entry [family], and finally verifies + -- the postconditions and the consequences of the contract cases. E denotes + -- the entry family. Decl denotes the declaration of the enclosing + -- synchronized type. + procedure Create_Generic_Contract (Unit : Node_Id); -- Create a contract node for a generic package, generic subprogram, or a -- generic body denoted by Unit by collecting all source contract-related @@ -188,21 +209,6 @@ package Contracts is -- denoted by Body_Decl. In addition, freeze the contract of the nearest -- enclosing package body. - function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id; - -- Get the defining identifier for a subprogram's Postcond_Enabled - -- object created during the expansion of the subprogram's postconditions. - - function Get_Result_Object_For_Postcond (Subp : Entity_Id) return Entity_Id; - -- Get the defining identifier for a subprogram's - -- Result_Object_For_Postcond object created during the expansion of the - -- subprogram's postconditions. - - function Get_Return_Success_For_Postcond - (Subp : Entity_Id) return Entity_Id; - -- Get the defining identifier for a subprogram's - -- Return_Success_For_Postcond object created during the expansion of the - -- subprogram's postconditions. - procedure Inherit_Subprogram_Contract (Subp : Entity_Id; From_Subp : Entity_Id); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d0bcdb0..94e729e 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -142,7 +142,7 @@ package body Debug is -- d_a Stop elaboration checks on accept or select statement -- d_b Use designated type model under No_Dynamic_Accessibility_Checks -- d_c CUDA compilation : compile for the host - -- d_d + -- d_d CUDA compilation : compile for the device -- d_e Ignore entry calls and requeue statements for elaboration -- d_f Issue info messages related to GNATprove usage -- d_g Disable large static aggregates @@ -201,7 +201,7 @@ package body Debug is -- d6 Default access unconstrained to thin pointers -- d7 Suppress version/source stamp/compilation time for -gnatv/-gnatl -- d8 Force opposite endianness in packed stuff - -- d9 Allow lock free implementation + -- d9 -- d.1 Enable unnesting of nested procedures -- d.2 Allow statements in declarative part @@ -345,8 +345,8 @@ package body Debug is -- d_a Ignore the effects of pragma Elaborate_All -- d_b Ignore the effects of pragma Elaborate_Body - -- d_c - -- d_d + -- d_c CUDA compilation : compile/bind for the host + -- d_d CUDA compilation : compile/bind for the device -- d_e Ignore the effects of pragma Elaborate -- d_f -- d_g @@ -1089,9 +1089,6 @@ package body Debug is -- opposite endianness from the actual correct value. Useful in -- testing out code generation from the packed routines. - -- d9 This allows lock free implementation for protected objects - -- (see Exp_Ch9). - -- d.1 Sets Opt.Unnest_Subprogram_Mode to enable unnesting of subprograms. -- This special pass does not actually unnest things, but it ensures -- that a nested procedure does not contain any uplevel references. diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst index 6ef00c2..4541f2b 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst @@ -317,23 +317,27 @@ The following is a typical example of use: type List is private with Iterable => (First => First_Cursor, Next => Advance, - Has_Element => Cursor_Has_Element, - [Element => Get_Element]); + Has_Element => Cursor_Has_Element + [,Element => Get_Element] + [,Last => Last_Cursor] + [,Previous => Retreat]); -* The value denoted by ``First`` must denote a primitive operation of the - container type that returns a ``Cursor``, which must a be a type declared in +* The values of ``First`` and ``Last`` are primitive operations of the + container type that return a ``Cursor``, which must be a type declared in the container package or visible from it. For example: .. code-block:: ada function First_Cursor (Cont : Container) return Cursor; + function Last_Cursor (Cont : Container) return Cursor; -* The value of ``Next`` is a primitive operation of the container type that takes - both a container and a cursor and yields a cursor. For example: +* The values of ``Next`` and ``Previous`` are primitive operations of the container type that take + both a container and a cursor and yield a cursor. For example: .. code-block:: ada function Advance (Cont : Container; Position : Cursor) return Cursor; + function Retreat (Cont : Container; Position : Cursor) return Cursor; * The value of ``Has_Element`` is a primitive operation of the container type that takes both a container and a cursor and yields a boolean. For example: diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index 1b4f4fe..c25e3d4 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -606,13 +606,6 @@ in this example: end Gen; -Attribute Lock_Free -=================== -.. index:: Lock_Free - -``P'Lock_Free``, where P is a protected object, returns True if a -pragma ``Lock_Free`` applies to P. - Attribute Loop_Entry ==================== .. index:: Loop_Entry diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 4318a34..53836c9 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -2262,7 +2262,8 @@ of GNAT specific extensions are recognized as follows: will not be executed if the earlier alternative "matches"). All possible values of the composite type shall be covered. The composite type of the selector shall be an array or record type that is neither limited - class-wide. + class-wide. Currently, a "when others =>" case choice is required; it is + intended that this requirement will be relaxed at some point. If a subcomponent's subtype does not meet certain restrictions, then the only value that can be specified for that subcomponent in a case @@ -3751,7 +3752,12 @@ In addition, each protected subprogram body must satisfy: * May not dereferenced access values * Function calls and attribute references must be static - +If the Lock_Free aspect is specified to be True for a protected unit +and the Ceiling_Locking locking policy is in effect, then the run-time +actions associated with the Ceiling_Locking locking policy (described in +Ada RM D.3) are not performed when a protected operation of the protected +unit is executed. + Pragma Loop_Invariant ===================== @@ -7119,7 +7125,7 @@ be. For the variable case, warnings are never given for unreferenced variables whose name contains one of the substrings -``DISCARD, DUMMY, IGNORE, JUNK, UNUSED`` in any casing. Such names +``DISCARD, DUMMY, IGNORE, JUNK, UNUSE, TMP, TEMP`` in any casing. Such names are typically to be used in cases where such warnings are expected. Thus it is never necessary to use ``pragma Unmodified`` for such variables, though it is harmless to do so. diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst index 524e3e0..d791f81 100644 --- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst +++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst @@ -120,225 +120,6 @@ instead of ``Character``. The provision of such a package is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). -.. _`Ada.Containers.Formal_Doubly_Linked_Lists_(a-cfdlli.ads)`: - -``Ada.Containers.Formal_Doubly_Linked_Lists`` (:file:`a-cfdlli.ads`) -==================================================================== - -.. index:: Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads) - -.. index:: Formal container for doubly linked lists - -This child of ``Ada.Containers`` defines a modified version of the -Ada 2005 container for doubly linked lists, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -.. _`Ada.Containers.Formal_Hashed_Maps_(a-cfhama.ads)`: - -``Ada.Containers.Formal_Hashed_Maps`` (:file:`a-cfhama.ads`) -============================================================ - -.. index:: Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads) - -.. index:: Formal container for hashed maps - -This child of ``Ada.Containers`` defines a modified version of the -Ada 2005 container for hashed maps, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -.. _`Ada.Containers.Formal_Hashed_Sets_(a-cfhase.ads)`: - -``Ada.Containers.Formal_Hashed_Sets`` (:file:`a-cfhase.ads`) -============================================================ - -.. index:: Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads) - -.. index:: Formal container for hashed sets - -This child of ``Ada.Containers`` defines a modified version of the -Ada 2005 container for hashed sets, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -.. _`Ada.Containers.Formal_Ordered_Maps_(a-cforma.ads)`: - -``Ada.Containers.Formal_Ordered_Maps`` (:file:`a-cforma.ads`) -============================================================= - -.. index:: Ada.Containers.Formal_Ordered_Maps (a-cforma.ads) - -.. index:: Formal container for ordered maps - -This child of ``Ada.Containers`` defines a modified version of the -Ada 2005 container for ordered maps, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -.. _`Ada.Containers.Formal_Ordered_Sets_(a-cforse.ads)`: - -``Ada.Containers.Formal_Ordered_Sets`` (:file:`a-cforse.ads`) -============================================================= - -.. index:: Ada.Containers.Formal_Ordered_Sets (a-cforse.ads) - -.. index:: Formal container for ordered sets - -This child of ``Ada.Containers`` defines a modified version of the -Ada 2005 container for ordered sets, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -.. _`Ada.Containers.Formal_Vectors_(a-cofove.ads)`: - -``Ada.Containers.Formal_Vectors`` (:file:`a-cofove.ads`) -======================================================== - -.. index:: Ada.Containers.Formal_Vectors (a-cofove.ads) - -.. index:: Formal container for vectors - -This child of ``Ada.Containers`` defines a modified version of the -Ada 2005 container for vectors, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -.. _`Ada.Containers.Formal_Indefinite_Vectors_(a-cfinve.ads)`: - -``Ada.Containers.Formal_Indefinite_Vectors`` (:file:`a-cfinve.ads`) -=================================================================== - -.. index:: Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads) - -.. index:: Formal container for vectors - -This child of ``Ada.Containers`` defines a modified version of the -Ada 2005 container for vectors of indefinite elements, meant to -facilitate formal verification of code using such containers. The -specification of this unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -.. _`Ada.Containers.Functional_Infinite_Sequences_(a-cfinse.ads)`: - -``Ada.Containers.Functional_Infinite_Sequences`` (:file:`a-cfinse.ads`) -======================================================================= - -.. index:: Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads) - -.. index:: Functional Infinite Sequences - -This child of ``Ada.Containers`` defines immutable sequences indexed by -``Big_Integer``. These containers are unbounded and may contain indefinite -elements. Their API features functions creating new containers from existing -ones. To remain reasonably efficient, their implementation involves sharing -between data-structures. As they are functional, that is, no primitives are -provided which would allow modifying an existing container, these containers -can still be used safely. - -These containers are controlled so that the allocated memory can be reclaimed -when the container is no longer referenced. Thus, they cannot directly be used -in contexts where controlled types are not supported. -The specification of this unit is compatible with SPARK 2014. - -.. _`Ada.Containers.Functional_Vectors_(a-cofuve.ads)`: - -``Ada.Containers.Functional_Vectors`` (:file:`a-cofuve.ads`) -============================================================ - -.. index:: Ada.Containers.Functional_Vectors (a-cofuve.ads) - -.. index:: Functional vectors - -This child of ``Ada.Containers`` defines immutable vectors. These -containers are unbounded and may contain indefinite elements. Furthermore, to -be usable in every context, they are neither controlled nor limited. As they -are functional, that is, no primitives are provided which would allow modifying -an existing container, these containers can still be used safely. - -Their API features functions creating new containers from existing ones. -As a consequence, these containers are highly inefficient. They are also -memory consuming, as the allocated memory is not reclaimed when the container -is no longer referenced. Thus, they should in general be used in ghost code -and annotations, so that they can be removed from the final executable. The -specification of this unit is compatible with SPARK 2014. - -.. _`Ada.Containers.Functional_Sets_(a-cofuse.ads)`: - -``Ada.Containers.Functional_Sets`` (:file:`a-cofuse.ads`) -========================================================= - -.. index:: Ada.Containers.Functional_Sets (a-cofuse.ads) - -.. index:: Functional sets - -This child of ``Ada.Containers`` defines immutable sets. These containers are -unbounded and may contain indefinite elements. Their API features functions -creating new containers from existing ones. To remain reasonably efficient, -their implementation involves sharing between data-structures. As they are -functional, that is, no primitives are provided which would allow modifying an -existing container, these containers can still be used safely. - -These containers are controlled so that the allocated memory can be reclaimed -when the container is no longer referenced. Thus, they cannot directly be used -in contexts where controlled types are not supported. -The specification of this unit is compatible with SPARK 2014. - -.. _`Ada.Containers.Functional_Maps_(a-cofuma.ads)`: - -``Ada.Containers.Functional_Maps`` (:file:`a-cofuma.ads`) -========================================================= - -.. index:: Ada.Containers.Functional_Maps (a-cofuma.ads) - -.. index:: Functional maps - -This child of ``Ada.Containers`` defines immutable maps. These containers are -unbounded and may contain indefinite elements. Their API features functions -creating new containers from existing ones. To remain reasonably efficient, -their implementation involves sharing between data-structures. As they are -functional, that is, no primitives are provided which would allow modifying an -existing container, these containers can still be used safely. - -These containers are controlled so that the allocated memory can be reclaimed -when the container is no longer referenced. Thus, they cannot directly be used -in contexts where controlled types are not supported. -The specification of this unit is compatible with SPARK 2014. - .. _`Ada.Containers.Bounded_Holders_(a-coboho.ads)`: ``Ada.Containers.Bounded_Holders`` (:file:`a-coboho.ads`) diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 37b6e95..6a47809 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -4455,7 +4455,7 @@ to the default checks required by Ada as described above. All validity checks are turned on. That is, :switch:`-gnatVa` is - equivalent to ``gnatVcdfimoprst``. + equivalent to ``gnatVcdefimoprst``. .. index:: -gnatVc (gcc) @@ -4463,8 +4463,8 @@ to the default checks required by Ada as described above. :switch:`-gnatVc` *Validity checks for copies.* - The right hand side of assignments, and the initializing values of - object declarations are validity checked. + The right-hand side of assignments, and the (explicit) initializing values + of object declarations are validity checked. .. index:: -gnatVd (gcc) @@ -4472,12 +4472,14 @@ to the default checks required by Ada as described above. :switch:`-gnatVd` *Default (RM) validity checks.* - Some validity checks are done by default following normal Ada semantics - (RM 13.9.1 (9-11)). - A check is done in case statements that the expression is within the range - of the subtype. If it is not, Constraint_Error is raised. - For assignments to array components, a check is done that the expression used - as index is within the range. If it is not, Constraint_Error is raised. + Some validity checks are required by Ada (see RM 13.9.1 (9-11)); these + (and only these) validity checks are enabled by default. + For case statements (and case expressions) that lack a "when others =>" + choice, a check is made that the value of the selector expression + belongs to its nominal subtype. If it does not, Constraint_Error is raised. + For assignments to array components (and for indexed components in some + other contexts), a check is made that each index expression belongs to the + corresponding index subtype. If it does not, Constraint_Error is raised. Both these validity checks may be turned off using switch :switch:`-gnatVD`. They are turned on by default. If :switch:`-gnatVD` is specified, a subsequent switch :switch:`-gnatVd` will leave the checks turned on. @@ -4490,28 +4492,31 @@ to the default checks required by Ada as described above. .. index:: -gnatVe (gcc) :switch:`-gnatVe` - *Validity checks for elementary components.* - - In the absence of this switch, assignments to record or array components are - not validity checked, even if validity checks for assignments generally - (:switch:`-gnatVc`) are turned on. In Ada, assignment of composite values do not - require valid data, but assignment of individual components does. So for - example, there is a difference between copying the elements of an array with a - slice assignment, compared to assigning element by element in a loop. This - switch allows you to turn off validity checking for components, even when they - are assigned component by component. + *Validity checks for scalar components.* + In the absence of this switch, assignments to scalar components of + enclosing record or array objects are not validity checked, even if + validity checks for assignments generally (:switch:`-gnatVc`) are turned on. + Specifying this switch enables such checks. + This switch has no effect if the :switch:`-gnatVc` switch is not specified. .. index:: -gnatVf (gcc) :switch:`-gnatVf` *Validity checks for floating-point values.* - In the absence of this switch, validity checking occurs only for discrete - values. If :switch:`-gnatVf` is specified, then validity checking also applies + Specifying this switch enables validity checking for floating-point + values in the same contexts where validity checking is enabled for + other scalar values. + In the absence of this switch, validity checking is not performed for + floating-point values. This takes precedence over other statements about + performing validity checking for scalar objects in various scenarios. + One way to look at it is that if this switch is not set, then whenever + any of the other rules in this section use the word "scalar" they + really mean "scalar and not floating-point". + If :switch:`-gnatVf` is specified, then validity checking also applies for floating-point values, and NaNs and infinities are considered invalid, - as well as out of range values for constrained types. Note that this means - that standard IEEE infinity mode is not allowed. The exact contexts + as well as out-of-range values for constrained types. The exact contexts in which floating-point values are checked depends on the setting of other options. For example, :switch:`-gnatVif` or :switch:`-gnatVfi` (the order does not matter) specifies that floating-point parameters of mode @@ -4558,7 +4563,8 @@ to the default checks required by Ada as described above. :switch:`-gnatVo` *Validity checks for operator and attribute operands.* - Arguments for predefined operators and attributes are validity checked. + Scalar arguments for predefined operators and for attributes are + validity checked. This includes all operators in package ``Standard``, the shift operators defined as intrinsic in package ``Interfaces`` and operands for attributes such as ``Pos``. Checks are also made @@ -4572,22 +4578,22 @@ to the default checks required by Ada as described above. :switch:`-gnatVp` *Validity checks for parameters.* - This controls the treatment of parameters within a subprogram (as opposed - to :switch:`-gnatVi` and :switch:`-gnatVm` which control validity testing - of parameters on a call. If either of these call options is used, then - normally an assumption is made within a subprogram that the input arguments - have been validity checking at the point of call, and do not need checking - again within a subprogram). If :switch:`-gnatVp` is set, then this assumption - is not made, and parameters are not assumed to be valid, so their validity - will be checked (or rechecked) within the subprogram. - + This controls the treatment of formal parameters within a subprogram (as + opposed to :switch:`-gnatVi` and :switch:`-gnatVm`, which control validity + testing of actual parameters of a call). If either of these call options is + specified, then normally an assumption is made within a subprogram that + the validity of any incoming formal parameters of the corresponding mode(s) + has already been checked at the point of call and does not need rechecking. + If :switch:`-gnatVp` is set, then this assumption is not made and so their + validity may be checked (or rechecked) within the subprogram. If neither of + the two call-related options is specified, then this switch has no effect. .. index:: -gnatVr (gcc) :switch:`-gnatVr` *Validity checks for function returns.* - The expression in ``return`` statements in functions is validity + The expression in simple ``return`` statements in functions is validity checked. @@ -4596,9 +4602,10 @@ to the default checks required by Ada as described above. :switch:`-gnatVs` *Validity checks for subscripts.* - All subscripts expressions are checked for validity, whether they appear - on the right side or left side (in default mode only left side subscripts - are validity checked). + All subscript expressions are checked for validity, whatever context + they occur in (in default mode some subscripts are not validity checked; + for example, validity checking may be omitted in some cases involving + a read of a component of an array). .. index:: -gnatVt (gcc) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ed63019..7ac8cf6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4014,9 +4014,7 @@ package Einfo is -- fully initialized when the full view is frozen. -- Postconditions_Proc --- Defined in functions, procedures, entries, and entry families. Refers --- to the entity of the _Postconditions procedure used to check contract --- assertions on exit from a subprogram. +-- Obsolete field which can be removed once CodePeer is fixed ??? -- Predicate_Function (synthesized) -- Defined in all types. Set for types for which (Has_Predicates is True) @@ -4767,6 +4765,13 @@ package Einfo is -- Defined in functions and procedures which have been classified as -- Is_Primitive_Wrapper. Set to the entity being wrapper. +-- Wrapped_Statements +-- Defined in functions, procedures, entries, and entry families. Refers +-- to the entity of the _Wrapped_Statements procedure which gets +-- generated as part of the expansion of contracts and postconditions +-- and contains its enclosing subprogram's original source declarations +-- and statements. + -- LSP_Subprogram -- Defined in subprogram entities. Set on wrappers created to handle -- inherited class-wide pre/post conditions that call overridden @@ -5412,7 +5417,6 @@ package Einfo is -- Protected_Body_Subprogram -- Barrier_Function -- Elaboration_Entity - -- Postconditions_Proc -- Entry_Parameters_Type -- First_Entity -- Alias (for entry only. Empty) @@ -5527,7 +5531,6 @@ package Einfo is -- Protected_Body_Subprogram -- Next_Inlined_Subprogram -- Elaboration_Entity (not implicit /=) - -- Postconditions_Proc (non-generic case only) -- DT_Position -- DTC_Entity -- First_Entity @@ -5891,7 +5894,6 @@ package Einfo is -- Protected_Body_Subprogram -- Next_Inlined_Subprogram -- Elaboration_Entity - -- Postconditions_Proc (non-generic case only) -- DT_Position -- DTC_Entity -- First_Entity diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index cab7fec..d0cbe9f 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -1317,8 +1317,8 @@ package body Erroutc is Name_Len := Name_Len - 1; end if; - -- If operator name or character literal name, just print it as is - -- Also print as is if it ends in a right paren (case of x'val(nnn)) + -- If operator name or character literal name, just print it as is. + -- Also print as is if it ends in a right paren (case of x'val(nnn)). if Name_Buffer (1) = '"' or else Name_Buffer (1) = ''' @@ -1534,6 +1534,32 @@ package body Erroutc is elsif Text = "_TYPE_INVARIANT" then Set_Msg_Str ("TYPE_INVARIANT'CLASS"); + -- Preserve casing for names that include acronyms + + elsif Text = "Cpp_Class" then + Set_Msg_Str ("CPP_Class"); + + elsif Text = "Cpp_Constructor" then + Set_Msg_Str ("CPP_Constructor"); + + elsif Text = "Cpp_Virtual" then + Set_Msg_Str ("CPP_Virtual"); + + elsif Text = "Cpp_Vtable" then + Set_Msg_Str ("CPP_Vtable"); + + elsif Text = "Persistent_Bss" then + Set_Msg_Str ("Persistent_BSS"); + + elsif Text = "Spark_Mode" then + Set_Msg_Str ("SPARK_Mode"); + + elsif Text = "Use_Vads_Size" then + Set_Msg_Str ("Use_VADS_Size"); + + elsif Text = "Vads_Size" then + Set_Msg_Str ("VADS_size"); + -- Normal case with no replacement else diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 52d47d9..0e79b5d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2079,7 +2079,8 @@ package body Exp_Attr is case Id is - -- Attributes related to Ada 2012 iterators + -- Attributes related to Ada 2012 iterators. They are only allowed in + -- attribute definition clauses and should never be expanded. when Attribute_Constant_Indexing | Attribute_Default_Iterator @@ -2088,7 +2089,7 @@ package body Exp_Attr is | Attribute_Iterator_Element | Attribute_Variable_Indexing => - null; + raise Program_Error; -- Internal attributes used to deal with Ada 2012 delayed aspects. These -- were already rejected by the parser. Thus they shouldn't appear here. @@ -4883,7 +4884,6 @@ package body Exp_Attr is --------- when Attribute_Old => Old : declare - Typ : constant Entity_Id := Etype (N); CW_Temp : Entity_Id; CW_Typ : Entity_Id; Decl : Node_Id; @@ -4895,24 +4895,25 @@ package body Exp_Attr is use Old_Attr_Util.Indirect_Temps; begin -- Generating C code we don't need to expand this attribute when - -- we are analyzing the internally built nested postconditions + -- we are analyzing the internally built nested _Wrapped_Statements -- procedure since it will be expanded inline (and later it will -- be removed by Expand_N_Subprogram_Body). It this expansion is -- performed in such case then the compiler generates unreferenced -- extra temporaries. if Modify_Tree_For_C - and then Chars (Current_Scope) = Name_uPostconditions + and then Chars (Current_Scope) = Name_uWrapped_Statements then return; end if; - -- Climb the parent chain looking for subprogram _Postconditions + -- Climb the parent chain looking for subprogram _Wrapped_Statements Subp := N; while Present (Subp) loop exit when Nkind (Subp) = N_Subprogram_Body - and then Chars (Defining_Entity (Subp)) = Name_uPostconditions; + and then Chars (Defining_Entity (Subp)) + = Name_uWrapped_Statements; -- If assertions are disabled, no need to create the declaration -- that preserves the value. The postcondition pragma in which @@ -4925,14 +4926,11 @@ package body Exp_Attr is Subp := Parent (Subp); end loop; + Subp := Empty; - -- 'Old can only appear in a postcondition, the generated body of - -- _Postconditions must be in the tree (or inlined if we are - -- generating C code). - - pragma Assert - (Present (Subp) - or else (Modify_Tree_For_C and then In_Inlined_Body)); + -- 'Old can only appear in the case where local contract-related + -- wrapper has been generated with the purpose of wrapping the + -- original declarations and statements. Temp := Make_Temporary (Loc, 'T', Pref); @@ -4952,8 +4950,7 @@ package body Exp_Attr is -- No need to push the scope when generating C code since the -- _Postcondition procedure has been inlined. - else pragma Assert (Modify_Tree_For_C); - pragma Assert (In_Inlined_Body); + else null; end if; @@ -4963,17 +4960,23 @@ package body Exp_Attr is if Present (Subp) then Ins_Nod := Subp; - -- Generating C, the postcondition procedure has been inlined and the - -- temporary is added before the first declaration of the enclosing - -- subprogram. + -- General case where the postcondtion checks occur after the call + -- to _Wrapped_Statements. - else pragma Assert (Modify_Tree_For_C); + else Ins_Nod := N; while Nkind (Ins_Nod) /= N_Subprogram_Body loop Ins_Nod := Parent (Ins_Nod); end loop; - Ins_Nod := First (Declarations (Ins_Nod)); + if Present (Corresponding_Spec (Ins_Nod)) + and then Present + (Wrapped_Statements (Corresponding_Spec (Ins_Nod))) + then + Ins_Nod := Last (Declarations (Ins_Nod)); + else + Ins_Nod := First (Declarations (Ins_Nod)); + end if; end if; if Eligible_For_Conditional_Evaluation (N) then @@ -4986,9 +4989,9 @@ package body Exp_Attr is -- unconditionally) or an evaluation statement (which is -- to be executed conditionally). - ------------------------------- - -- Append_For_Indirect_Temp -- - ------------------------------- + ------------------------------ + -- Append_For_Indirect_Temp -- + ------------------------------ procedure Append_For_Indirect_Temp (N : Node_Id; Is_Eval_Stmt : Boolean) @@ -5008,7 +5011,7 @@ package body Exp_Attr is Declare_Indirect_Temporary (Attr_Prefix => Pref, Indirect_Temp => Temp); - Insert_Before_And_Analyze ( + Insert_After_And_Analyze ( Ins_Nod, Make_If_Statement (Sloc => Loc, @@ -5085,7 +5088,17 @@ package body Exp_Attr is -- to reflect the new placement of the prefix. if Validity_Checks_On and then Validity_Check_Operands then - Ensure_Valid (Expression (Decl)); + + -- Object declaration that captures the attribute prefix might + -- be rewritten into object renaming declaration. + + if Nkind (Decl) = N_Object_Declaration then + Ensure_Valid (Expression (Decl)); + else + pragma Assert (Nkind (Decl) = N_Object_Renaming_Declaration + and then Is_Rewrite_Substitution (Decl)); + Ensure_Valid (Name (Decl)); + end if; end if; Rewrite (N, New_Occurrence_Of (Temp, Loc)); @@ -7102,7 +7115,11 @@ package body Exp_Attr is -- See separate sections below for the generated code in each case. when Attribute_Valid => Valid : declare - PBtyp : Entity_Id := Base_Type (Ptyp); + PBtyp : Entity_Id := Implementation_Base_Type (Validated_View (Ptyp)); + pragma Assert (Is_Scalar_Type (PBtyp) + or else Serious_Errors_Detected > 0); + + -- The scalar base type, looking through private types Save_Validity_Checks_On : constant Boolean := Validity_Checks_On; -- Save the validity checking mode. We always turn off validity @@ -7149,21 +7166,27 @@ package body Exp_Attr is Temp := Duplicate_Subexpr (Pref); end if; - return - Make_In (Loc, - Left_Opnd => Unchecked_Convert_To (PBtyp, Temp), - Right_Opnd => - Make_Range (Loc, - Low_Bound => - Unchecked_Convert_To (PBtyp, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_First)), - High_Bound => - Unchecked_Convert_To (PBtyp, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ptyp, Loc), - Attribute_Name => Name_Last)))); + declare + Val_Typ : constant Entity_Id := Validated_View (Ptyp); + begin + return + Make_In (Loc, + Left_Opnd => Unchecked_Convert_To (PBtyp, Temp), + Right_Opnd => + Make_Range (Loc, + Low_Bound => + Unchecked_Convert_To (PBtyp, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Val_Typ, Loc), + Attribute_Name => Name_First)), + High_Bound => + Unchecked_Convert_To (PBtyp, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Val_Typ, Loc), + Attribute_Name => Name_Last)))); + end; end Make_Range_Test; -- Local variables @@ -7185,13 +7208,6 @@ package body Exp_Attr is Validity_Checks_On := False; - -- Retrieve the base type. Handle the case where the base type is a - -- private enumeration type. - - if Is_Private_Type (PBtyp) and then Present (Full_View (PBtyp)) then - PBtyp := Full_View (PBtyp); - end if; - -- Floating-point case. This case is handled by the Valid attribute -- code in the floating-point attribute run-time library. @@ -7461,7 +7477,7 @@ package body Exp_Attr is Uns : constant Boolean := Is_Unsigned_Type (Ptyp) or else (Is_Private_Type (Ptyp) - and then Is_Unsigned_Type (Btyp)); + and then Is_Unsigned_Type (PBtyp)); Size : Uint; P : Node_Id := Pref; @@ -7946,7 +7962,6 @@ package body Exp_Attr is | Attribute_Large | Attribute_Last_Valid | Attribute_Library_Level - | Attribute_Lock_Free | Attribute_Machine_Emax | Attribute_Machine_Emin | Attribute_Machine_Mantissa diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index c4a59f5..98ce886 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1305,9 +1305,6 @@ package body Exp_Ch11 is then pragma Assert (not Is_Thunk (Current_Scope)); Expand_Cleanup_Actions (Parent (N)); - - else - Set_First_Real_Statement (N, First (Statements (N))); end if; end Expand_N_Handled_Sequence_Of_Statements; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 18fb88f..0b7e391 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6135,6 +6135,10 @@ package body Exp_Ch4 is -- itself such a slice, in order to catch if expressions with more than -- two dependent expressions in the source code. + -- Also note that this creates variables on branches without an explicit + -- scope, causing troubles with e.g. the LLVM IR, so disable this + -- optimization when Unnest_Subprogram_Mode (enabled for LLVM). + elsif Is_Array_Type (Typ) and then Number_Dimensions (Typ) = 1 and then not Is_Constrained (Typ) @@ -6151,6 +6155,7 @@ package body Exp_Ch4 is and then OK_For_Single_Subtype (Etype (Thenx), Etype (Prefix (Elsex))))) and then not Generate_C_Code + and then not Unnest_Subprogram_Mode then declare Ityp : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index fe3bb5b..0873191 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -26,7 +26,6 @@ with Atree; use Atree; with Aspects; use Aspects; with Checks; use Checks; -with Contracts; use Contracts; with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; @@ -2729,11 +2728,16 @@ package body Exp_Ch6 is | N_Function_Call | N_Procedure_Call_Statement); - -- Check that this is not the call in the body of the wrapper + -- Check that this is not the call in the body of the access + -- subprogram wrapper or the postconditions wrapper. if Must_Rewrite_Indirect_Call and then (not Is_Overloadable (Current_Scope) - or else not Is_Access_Subprogram_Wrapper (Current_Scope)) + or else not (Is_Access_Subprogram_Wrapper (Current_Scope) + or else + (Chars (Current_Scope) = Name_uWrapped_Statements + and then Is_Access_Subprogram_Wrapper + (Scope (Current_Scope))))) then declare Loc : constant Source_Ptr := Sloc (N); @@ -4871,11 +4875,12 @@ package body Exp_Ch6 is then Must_Inline := not In_Extended_Main_Source_Unit (Subp); - -- Inline calls to _postconditions when generating C code + -- Inline calls to _Wrapped_Statements when generating C elsif Modify_Tree_For_C and then In_Same_Extended_Unit (Sloc (Bod), Loc) - and then Chars (Name (Call_Node)) = Name_uPostconditions + and then Chars (Name (Call_Node)) + = Name_uWrapped_Statements then Must_Inline := True; end if; @@ -5047,11 +5052,11 @@ package body Exp_Ch6 is Set_Analyzed (N); - -- A function which returns a controlled object uses the secondary - -- stack. Rewrite the call into a temporary which obtains the result of - -- the function using 'reference. + -- Apply the transformation, unless it was already applied manually - Remove_Side_Effects (N); + if Nkind (Par) /= N_Reference then + Remove_Side_Effects (N); + end if; -- The side effect removal of the function call produced a temporary. -- When the context is a case expression, if expression, or expression @@ -5567,45 +5572,6 @@ package body Exp_Ch6 is Append_To (Stmts, Stmt); Set_Analyzed (Stmt); - -- Call the _Postconditions procedure if the related subprogram - -- has contract assertions that need to be verified on exit. - - -- Also, mark the successful return to signal that postconditions - -- need to be evaluated when finalization occurs by setting - -- Return_Success_For_Postcond to be True. - - if Ekind (Spec_Id) = E_Procedure - and then Present (Postconditions_Proc (Spec_Id)) - then - -- Generate: - -- - -- Return_Success_For_Postcond := True; - -- if Postcond_Enabled then - -- _postconditions; - -- end if; - - Insert_Action (Stmt, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Get_Return_Success_For_Postcond (Spec_Id), Loc), - Expression => New_Occurrence_Of (Standard_True, Loc))); - - -- Wrap the call to _postconditions within a test of the - -- Postcond_Enabled flag to delay postcondition evaluation - -- until after finalization when required. - - Insert_Action (Stmt, - Make_If_Statement (Loc, - Condition => - New_Occurrence_Of (Get_Postcond_Enabled (Spec_Id), Loc), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (Postconditions_Proc (Spec_Id), Loc))))); - end if; - -- Ada 2022 (AI12-0279): append the call to 'Yield unless this is -- a generic subprogram (since in such case it will be added to -- the instantiations). @@ -6013,44 +5979,6 @@ package body Exp_Ch6 is Lab_Node : Node_Id; begin - -- Call the _Postconditions procedure if the related subprogram has - -- contract assertions that need to be verified on exit. - - -- Also, mark the successful return to signal that postconditions need - -- to be evaluated when finalization occurs. - - if Ekind (Scope_Id) in E_Entry | E_Entry_Family | E_Procedure - and then Present (Postconditions_Proc (Scope_Id)) - then - -- Generate: - -- - -- Return_Success_For_Postcond := True; - -- if Postcond_Enabled then - -- _postconditions; - -- end if; - - Insert_Action (N, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Get_Return_Success_For_Postcond (Scope_Id), Loc), - Expression => New_Occurrence_Of (Standard_True, Loc))); - - -- Wrap the call to _postconditions within a test of the - -- Postcond_Enabled flag to delay postcondition evaluation until - -- after finalization when required. - - Insert_Action (N, - Make_If_Statement (Loc, - Condition => - New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (Postconditions_Proc (Scope_Id), Loc))))); - end if; - -- Ada 2022 (AI12-0279) if Has_Yield_Aspect (Scope_Id) @@ -6995,84 +6923,6 @@ package body Exp_Ch6 is end; end if; - -- Call the _Postconditions procedure if the related function has - -- contract assertions that need to be verified on exit. - - if Ekind (Scope_Id) = E_Function - and then Present (Postconditions_Proc (Scope_Id)) - then - -- In the case of discriminated objects, we have created a - -- constrained subtype above, and used the underlying type. This - -- transformation is post-analysis and harmless, except that now the - -- call to the post-condition will be analyzed and the type kinds - -- have to match. - - if Nkind (Exp) = N_Unchecked_Type_Conversion - and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp)) - then - Rewrite (Exp, Expression (Relocate_Node (Exp))); - end if; - - -- We are going to reference the returned value twice in this case, - -- once in the call to _Postconditions, and once in the actual return - -- statement, but we can't have side effects happening twice. - - Force_Evaluation (Exp, Mode => Strict); - - -- Save the return value or a pointer to the return value since we - -- may need to call postconditions after finalization when cleanup - -- actions are present. - - -- Generate: - -- - -- Result_Object_For_Postcond := [Exp]'Unrestricted_Access; - - Insert_Action (Exp, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Get_Result_Object_For_Postcond (Scope_Id), Loc), - Expression => - (if Is_Elementary_Type (Etype (R_Type)) then - New_Copy_Tree (Exp) - else - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Unrestricted_Access, - Prefix => New_Copy_Tree (Exp))))); - - -- Mark the successful return to signal that postconditions need to - -- be evaluated when finalization occurs. - - -- Generate: - -- - -- Return_Success_For_Postcond := True; - -- if Postcond_Enabled then - -- _Postconditions ([exp]); - -- end if; - - Insert_Action (Exp, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Get_Return_Success_For_Postcond (Scope_Id), Loc), - Expression => New_Occurrence_Of (Standard_True, Loc))); - - -- Wrap the call to _postconditions within a test of the - -- Postcond_Enabled flag to delay postcondition evaluation until - -- after finalization when required. - - Insert_Action (Exp, - Make_If_Statement (Loc, - Condition => - New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (Postconditions_Proc (Scope_Id), Loc), - Parameter_Associations => New_List (New_Copy_Tree (Exp)))))); - end if; - -- Ada 2005 (AI-251): If this return statement corresponds with an -- simple return statement associated with an extended return statement -- and the type of the returned object is an interface then generate an diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 7ce39f4..fc4516d 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -28,7 +28,6 @@ -- - transient scopes with Atree; use Atree; -with Contracts; use Contracts; with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; @@ -59,7 +58,6 @@ with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Sem; use Sem; with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; @@ -306,17 +304,6 @@ package body Exp_Ch7 is -- such as for task termination. Fin_Id is the finalizer declaration -- entity. - procedure Build_Finalizer_Helper - (N : Node_Id; - Clean_Stmts : List_Id; - Mark_Id : Entity_Id; - Top_Decls : List_Id; - Defer_Abort : Boolean; - Fin_Id : out Entity_Id; - Finalize_Old_Only : Boolean); - -- An internal routine which does all of the heavy lifting on behalf of - -- Build_Finalizer. - procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id); -- N is a construct that contains a handled sequence of statements, Fin_Id -- is the entity of a finalizer. Create an At_End handler that covers the @@ -927,10 +914,6 @@ package body Exp_Ch7 is pragma Assert (Present (Param)); pragma Assert (Present (Conc_Typ)); - -- Historical note: In earlier versions of GNAT, there was code - -- at this point to generate stuff to service entry queues. It is - -- now abstracted in Build_Protected_Subprogram_Call_Cleanup. - Build_Protected_Subprogram_Call_Cleanup (Specification (N), Conc_Typ, Loc, Stmts); end; @@ -1382,18 +1365,17 @@ package body Exp_Ch7 is end; end Build_Finalization_Master; - ---------------------------- - -- Build_Finalizer_Helper -- - ---------------------------- + --------------------- + -- Build_Finalizer -- + --------------------- - procedure Build_Finalizer_Helper + procedure Build_Finalizer (N : Node_Id; Clean_Stmts : List_Id; Mark_Id : Entity_Id; Top_Decls : List_Id; Defer_Abort : Boolean; - Fin_Id : out Entity_Id; - Finalize_Old_Only : Boolean) + Fin_Id : out Entity_Id) is Acts_As_Clean : constant Boolean := Present (Mark_Id) @@ -1687,15 +1669,9 @@ package body Exp_Ch7 is -- there will need to be multiple finalization routines in the -- same scope. See Build_Finalizer for details. - if Finalize_Old_Only then - Fin_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Name_uFinalizer_Old)); - else - Fin_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Name_uFinalizer)); - end if; + Fin_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Name_uFinalizer)); -- The visibility semantics of AT_END handlers force a strange -- separation of spec and body for stack-related finalizers: @@ -2066,10 +2042,15 @@ package body Exp_Ch7 is -- In the case where the last construct to contain a controlled -- object is either a nested package, an instantiation or a -- freeze node, the body must be inserted directly after the - -- construct. + -- construct, except if the insertion point is already placed + -- after the construct, typically in the statement list. if Nkind (Last_Top_Level_Ctrl_Construct) in N_Freeze_Entity | N_Package_Declaration | N_Package_Body + and then not + (List_Containing (Last_Top_Level_Ctrl_Construct) = Spec_Decls + and then Present (Stmts) + and then List_Containing (Finalizer_Insert_Nod) = Stmts) then Finalizer_Insert_Nod := Last_Top_Level_Ctrl_Construct; end if; @@ -2222,26 +2203,9 @@ package body Exp_Ch7 is Decl := Last_Non_Pragma (Decls); while Present (Decl) loop - -- Depending on the value of flag Finalize_Old_Only we determine - -- which objects get finalized as part of the current finalizer - -- being built. - - -- When True, only temporaries capturing the value of attribute - -- 'Old are finalized and all other cases are ignored. - - -- When False, temporary objects used to capture the value of 'Old - -- are ignored and all others are considered. - - if Finalize_Old_Only - xor (Nkind (Decl) = N_Object_Declaration - and then Stores_Attribute_Old_Prefix - (Defining_Identifier (Decl))) - then - null; - -- Library-level tagged types - elsif Nkind (Decl) = N_Full_Type_Declaration then + if Nkind (Decl) = N_Full_Type_Declaration then Typ := Defining_Identifier (Decl); -- Ignored Ghost types do not need any cleanup actions because @@ -2546,7 +2510,7 @@ package body Exp_Ch7 is -- template and not the actually instantiation -- (which is generated too late for us to process -- it), so there is no need to update in particular - -- to update Last_Top_Level_Ctrl_Construct here. + -- Last_Top_Level_Ctrl_Construct here. if Counter_Val > Old_Counter_Val then Counter_Val := Old_Counter_Val; @@ -3528,7 +3492,7 @@ package body Exp_Ch7 is New_Occurrence_Of (DT_Ptr, Loc)))); end Process_Tagged_Type_Declaration; - -- Start of processing for Build_Finalizer_Helper + -- Start of processing for Build_Finalizer begin Fin_Id := Empty; @@ -3685,22 +3649,13 @@ package body Exp_Ch7 is if Acts_As_Clean or Has_Ctrl_Objs or Has_Tagged_Types then Create_Finalizer; end if; - end Build_Finalizer_Helper; + end Build_Finalizer; -------------------------- -- Build_Finalizer_Call -- -------------------------- procedure Build_Finalizer_Call (N : Node_Id; Fin_Id : Entity_Id) is - Is_Protected_Subp_Body : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Is_Protected_Subprogram_Body (N); - -- Determine whether N denotes the protected version of a subprogram - -- which belongs to a protected type. - - Loc : constant Source_Ptr := Sloc (N); - HSS : Node_Id := Handled_Statement_Sequence (N); - begin -- Do not perform this expansion in SPARK mode because we do not create -- finalizers in the first place. @@ -3730,512 +3685,43 @@ package body Exp_Ch7 is -- end; -- end Prot_SubpP; - if Is_Protected_Subp_Body then - HSS := Handled_Statement_Sequence (Last (Statements (HSS))); - end if; - - pragma Assert (No (At_End_Proc (HSS))); - Set_At_End_Proc (HSS, New_Occurrence_Of (Fin_Id, Loc)); - - -- Attach reference to finalizer to tree, for LLVM use - - Set_Parent (At_End_Proc (HSS), HSS); + declare + Loc : constant Source_Ptr := Sloc (N); - Analyze (At_End_Proc (HSS)); - Expand_At_End_Handler (HSS, Empty); + Is_Protected_Subp_Body : constant Boolean := + Nkind (N) = N_Subprogram_Body + and then Is_Protected_Subprogram_Body (N); + -- True if N is the protected version of a subprogram that belongs to + -- a protected type. + + HSS : constant Node_Id := + (if Is_Protected_Subp_Body + then Handled_Statement_Sequence + (Last (Statements (Handled_Statement_Sequence (N)))) + else Handled_Statement_Sequence (N)); + + -- We attach the At_End_Proc to the HSS if this is an accept + -- statement or extended return statement. Also in the case of + -- a protected subprogram, because if Service_Entries raises an + -- exception, we do not lock the PO, so we also do not want to + -- unlock it. + + Use_HSS : constant Boolean := + Nkind (N) in N_Accept_Statement | N_Extended_Return_Statement + or else Is_Protected_Subp_Body; + + At_End_Proc_Bearer : constant Node_Id := (if Use_HSS then HSS else N); + begin + pragma Assert (No (At_End_Proc (At_End_Proc_Bearer))); + Set_At_End_Proc (At_End_Proc_Bearer, New_Occurrence_Of (Fin_Id, Loc)); + -- Attach reference to finalizer to tree, for LLVM use + Set_Parent (At_End_Proc (At_End_Proc_Bearer), At_End_Proc_Bearer); + Analyze (At_End_Proc (At_End_Proc_Bearer)); + Expand_At_End_Handler (At_End_Proc_Bearer, Empty); + end; end Build_Finalizer_Call; --------------------- - -- Build_Finalizer -- - --------------------- - - procedure Build_Finalizer - (N : Node_Id; - Clean_Stmts : List_Id; - Mark_Id : Entity_Id; - Top_Decls : List_Id; - Defer_Abort : Boolean; - Fin_Id : out Entity_Id) - is - Def_Ent : constant Entity_Id := Unique_Defining_Entity (N); - Loc : constant Source_Ptr := Sloc (N); - - -- Declarations used for the creation of _finalization_controller - - Fin_Old_Id : Entity_Id := Empty; - Fin_Controller_Id : Entity_Id := Empty; - Fin_Controller_Decls : List_Id; - Fin_Controller_Stmts : List_Id; - Fin_Controller_Body : Node_Id := Empty; - Fin_Controller_Spec : Node_Id := Empty; - Postconditions_Call : Node_Id := Empty; - - -- Defining identifiers for local objects used to store exception info - - Raised_Post_Exception_Id : Entity_Id := Empty; - Raised_Finalization_Exception_Id : Entity_Id := Empty; - Saved_Exception_Id : Entity_Id := Empty; - - -- Start of processing for Build_Finalizer - - begin - -- Create the general finalization routine - - Build_Finalizer_Helper - (N => N, - Clean_Stmts => Clean_Stmts, - Mark_Id => Mark_Id, - Top_Decls => Top_Decls, - Defer_Abort => Defer_Abort, - Fin_Id => Fin_Id, - Finalize_Old_Only => False); - - -- When postconditions are present, expansion gets much more complicated - -- due to both the fact that they must be called after finalization and - -- that finalization of 'Old objects must occur after the postconditions - -- get checked. - - -- Additionally, exceptions between general finalization and 'Old - -- finalization must be propagated correctly and exceptions which happen - -- during _postconditions need to be saved and reraised after - -- finalization of 'Old objects. - - -- Generate: - -- - -- Postcond_Enabled := False; - -- - -- procedure _finalization_controller is - -- - -- -- Exception capturing and tracking - -- - -- Saved_Exception : Exception_Occurrence; - -- Raised_Post_Exception : Boolean := False; - -- Raised_Finalization_Exception : Boolean := False; - -- - -- -- Start of processing for _finalization_controller - -- - -- begin - -- -- Perform general finalization - -- - -- begin - -- _finalizer; - -- exception - -- when others => - -- -- Save the exception - -- - -- Raised_Finalization_Exception := True; - -- Save_Occurrence - -- (Saved_Exception, Get_Current_Excep.all); - -- end; - -- - -- -- Perform postcondition checks after general finalization, but - -- -- before finalization of 'Old related objects. - -- - -- if not Raised_Finalization_Exception - -- and then Return_Success_For_Postcond - -- then - -- begin - -- -- Re-enable postconditions and check them - -- - -- Postcond_Enabled := True; - -- _postconditions [(Result_Obj_For_Postcond[.all])]; - -- exception - -- when others => - -- -- Save the exception - -- - -- Raised_Post_Exception := True; - -- Save_Occurrence - -- (Saved_Exception, Get_Current_Excep.all); - -- end; - -- end if; - -- - -- -- Finally finalize 'Old related objects - -- - -- begin - -- _finalizer_old; - -- exception - -- when others => - -- -- Reraise the previous finalization error if there is - -- -- one. - -- - -- if Raised_Finalization_Exception then - -- Reraise_Occurrence (Saved_Exception); - -- end if; - -- - -- -- Otherwise, reraise the current one - -- - -- raise; - -- end; - -- - -- -- Reraise any saved exception - -- - -- if Raised_Finalization_Exception - -- or else Raised_Post_Exception - -- then - -- Reraise_Occurrence (Saved_Exception); - -- end if; - -- end _finalization_controller; - - if Nkind (N) = N_Subprogram_Body - and then Present (Postconditions_Proc (Def_Ent)) - then - Fin_Controller_Stmts := New_List; - Fin_Controller_Decls := New_List; - - -- Build the 'Old finalizer - - Build_Finalizer_Helper - (N => N, - Clean_Stmts => Empty_List, - Mark_Id => Mark_Id, - Top_Decls => Top_Decls, - Defer_Abort => Defer_Abort, - Fin_Id => Fin_Old_Id, - Finalize_Old_Only => True); - - -- Create local declarations for _finalization_controller needed for - -- saving exceptions. - -- - -- Generate: - -- - -- Saved_Exception : Exception_Occurrence; - -- Raised_Post_Exception : Boolean := False; - -- Raised_Finalization_Exception : Boolean := False; - - Saved_Exception_Id := Make_Temporary (Loc, 'S'); - Raised_Post_Exception_Id := Make_Temporary (Loc, 'P'); - Raised_Finalization_Exception_Id := Make_Temporary (Loc, 'F'); - - Append_List_To (Fin_Controller_Decls, New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Saved_Exception_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)), - Make_Object_Declaration (Loc, - Defining_Identifier => Raised_Post_Exception_Id, - Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => New_Occurrence_Of (Standard_False, Loc)), - Make_Object_Declaration (Loc, - Defining_Identifier => Raised_Finalization_Exception_Id, - Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => New_Occurrence_Of (Standard_False, Loc)))); - - -- Call _finalizer and save any exceptions which occur - - -- Generate: - -- - -- begin - -- _finalizer; - -- exception - -- when others => - -- Raised_Finalization_Exception := True; - -- Save_Occurrence - -- (Saved_Exception, Get_Current_Excep.all); - -- end; - - if Present (Fin_Id) then - Append_To (Fin_Controller_Stmts, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Fin_Id, Loc))), - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List ( - Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Raised_Finalization_Exception_Id, Loc), - Expression => - New_Occurrence_Of (Standard_True, Loc)), - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Save_Occurrence), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of - (Saved_Exception_Id, Loc), - Make_Explicit_Dereference (Loc, - Prefix => - Make_Function_Call (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => - New_Occurrence_Of - (RTE (RE_Get_Current_Excep), - Loc)))))))))))); - end if; - - -- Create the call to postconditions based on the kind of the current - -- subprogram, and the type of the Result_Obj_For_Postcond. - - -- Generate: - -- - -- _postconditions (Result_Obj_For_Postcond[.all]); - -- - -- or - -- - -- _postconditions; - - if Ekind (Def_Ent) = E_Procedure then - Postconditions_Call := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (Postconditions_Proc (Def_Ent), Loc)); - else - Postconditions_Call := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (Postconditions_Proc (Def_Ent), Loc), - Parameter_Associations => New_List ( - (if Is_Elementary_Type (Etype (Def_Ent)) then - New_Occurrence_Of - (Get_Result_Object_For_Postcond - (Def_Ent), Loc) - else - Make_Explicit_Dereference (Loc, - New_Occurrence_Of - (Get_Result_Object_For_Postcond - (Def_Ent), Loc))))); - end if; - - -- Call _postconditions when no general finalization exceptions have - -- occurred taking care to enable the postconditions and save any - -- exception occurrences. - - -- Generate: - -- - -- if not Raised_Finalization_Exception - -- and then Return_Success_For_Postcond - -- then - -- begin - -- Postcond_Enabled := True; - -- _postconditions [(Result_Obj_For_Postcond[.all])]; - -- exception - -- when others => - -- Raised_Post_Exception := True; - -- Save_Occurrence - -- (Saved_Exception, Get_Current_Excep.all); - -- end; - -- end if; - - Append_To (Fin_Controller_Stmts, - Make_If_Statement (Loc, - Condition => - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Not (Loc, - Right_Opnd => - New_Occurrence_Of - (Raised_Finalization_Exception_Id, Loc)), - Right_Opnd => - New_Occurrence_Of - (Get_Return_Success_For_Postcond (Def_Ent), Loc)), - Then_Statements => New_List ( - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Get_Postcond_Enabled (Def_Ent), Loc), - Expression => - New_Occurrence_Of - (Standard_True, Loc)), - Postconditions_Call), - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List ( - Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Raised_Post_Exception_Id, Loc), - Expression => - New_Occurrence_Of (Standard_True, Loc)), - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Save_Occurrence), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of - (Saved_Exception_Id, Loc), - Make_Explicit_Dereference (Loc, - Prefix => - Make_Function_Call (Loc, - Name => - Make_Explicit_Dereference (Loc, - Prefix => - New_Occurrence_Of - (RTE (RE_Get_Current_Excep), - Loc)))))))))))))); - - -- Call _finalizer_old and reraise any exception that occurred during - -- initial finalization within the exception handler. Otherwise, - -- propagate the current exception. - - -- Generate: - -- - -- begin - -- _finalizer_old; - -- exception - -- when others => - -- if Raised_Finalization_Exception then - -- Reraise_Occurrence (Saved_Exception); - -- end if; - -- raise; - -- end; - - if Present (Fin_Old_Id) then - Append_To (Fin_Controller_Stmts, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Fin_Old_Id, Loc))), - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List ( - Make_Others_Choice (Loc)), - Statements => New_List ( - Make_If_Statement (Loc, - Condition => - New_Occurrence_Of - (Raised_Finalization_Exception_Id, Loc), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Reraise_Occurrence), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of - (Saved_Exception_Id, Loc))))), - Make_Raise_Statement (Loc))))))); - end if; - - -- Once finalization is complete reraise any pending exceptions - - -- Generate: - -- - -- if Raised_Post_Exception - -- or else Raised_Finalization_Exception - -- then - -- Reraise_Occurrence (Saved_Exception); - -- end if; - - Append_To (Fin_Controller_Stmts, - Make_If_Statement (Loc, - Condition => - Make_Or_Else (Loc, - Left_Opnd => - New_Occurrence_Of - (Raised_Post_Exception_Id, Loc), - Right_Opnd => - New_Occurrence_Of - (Raised_Finalization_Exception_Id, Loc)), - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of - (Saved_Exception_Id, Loc)))))); - - -- Make the finalization controller subprogram body and declaration. - - -- Generate: - -- procedure _finalization_controller; - -- - -- procedure _finalization_controller is - -- begin - -- [Fin_Controller_Stmts]; - -- end; - - Fin_Controller_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Name_uFinalization_Controller)); - - Fin_Controller_Spec := - Make_Subprogram_Declaration (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Fin_Controller_Id)); - - Fin_Controller_Body := - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Chars (Fin_Controller_Id))), - Declarations => Fin_Controller_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Controller_Stmts)); - - -- Disable _postconditions calls which get generated before return - -- statements to delay their evaluation until after finalization. - - -- This is done by way of the local Postcond_Enabled object which is - -- initially assigned to True - we then create an assignment within - -- the subprogram's declaration to make it False and assign it back - -- to True before _postconditions is called within - -- _finalization_controller. - - -- Generate: - -- - -- Postcond_Enable := False; - - -- Note that we do not disable early evaluation of postconditions - -- for return types that are unconstrained or have unconstrained - -- elements since the temporary result object could get allocated on - -- the stack and be out of scope at the point where we perform late - -- evaluation of postconditions - leading to uninitialized memory - -- reads. - - -- This disabling of early evaluation can lead to incorrect run-time - -- semantics where functions with unconstrained elements will - -- have their corresponding postconditions evaluated before - -- finalization. The proper solution here is to generate a wrapper - -- to capture the result instead of using multiple flags and playing - -- with flags which does not even work in all cases ??? - - if not Has_Unconstrained_Elements (Etype (Def_Ent)) - or else (Is_Array_Type (Etype (Def_Ent)) - and then not Is_Constrained (Etype (Def_Ent))) - then - Append_To (Top_Decls, - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of - (Get_Postcond_Enabled (Def_Ent), Loc), - Expression => - New_Occurrence_Of - (Standard_False, Loc))); - end if; - - -- Add the subprogram to the list of declarations an analyze it - - Append_To (Top_Decls, Fin_Controller_Spec); - Analyze (Fin_Controller_Spec); - Insert_After (Fin_Controller_Spec, Fin_Controller_Body); - Analyze (Fin_Controller_Body, Suppress => All_Checks); - - -- Return the finalization controller as the result Fin_Id - - Fin_Id := Fin_Controller_Id; - end if; - end Build_Finalizer; - - --------------------- -- Build_Late_Proc -- --------------------- @@ -5544,12 +5030,6 @@ package body Exp_Ch7 is Nkind (N) = N_Block_Statement and then Present (Cleanup_Actions (N)); - Has_Postcondition : constant Boolean := - Nkind (N) = N_Subprogram_Body - and then Present - (Postconditions_Proc - (Unique_Defining_Entity (N))); - Actions_Required : constant Boolean := Requires_Cleanup_Actions (N, True) or else Is_Asynchronous_Call @@ -5560,47 +5040,9 @@ package body Exp_Ch7 is or else Needs_Sec_Stack_Mark or else Needs_Custom_Cleanup; - HSS : Node_Id := Handled_Statement_Sequence (N); Loc : Source_Ptr; Cln : List_Id; - procedure Wrap_HSS_In_Block; - -- Move HSS inside a new block along with the original exception - -- handlers. Make the newly generated block the sole statement of HSS. - - ----------------------- - -- Wrap_HSS_In_Block -- - ----------------------- - - procedure Wrap_HSS_In_Block is - Block : constant Node_Id := - Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS); - Block_Id : constant Entity_Id := - New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); - End_Lab : constant Node_Id := End_Label (HSS); - -- Preserve end label to provide proper cross-reference information - - begin - Set_Identifier (Block, New_Occurrence_Of (Block_Id, Loc)); - Set_Etype (Block_Id, Standard_Void_Type); - Set_Block_Node (Block_Id, Identifier (Block)); - - -- Signal the finalization machinery that this particular block - -- contains the original context. - - Set_Is_Finalization_Wrapper (Block); - - HSS := Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Block), - End_Label => End_Lab); - Set_First_Real_Statement (HSS, Block); - Set_Handled_Statement_Sequence (N, HSS); - - if Nkind (N) = N_Subprogram_Body then - Set_Has_Nested_Block_With_Handler (Scop); - end if; - end Wrap_HSS_In_Block; - -- Start of processing for Expand_Cleanup_Actions begin @@ -5671,12 +5113,14 @@ package body Exp_Ch7 is Cln := No_List; end if; - declare - Decls : List_Id := Declarations (N); - Fin_Id : Entity_Id; - Mark : Entity_Id := Empty; - New_Decls : List_Id; + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + declare + Decls : constant List_Id := Declarations (N); + Fin_Id : Entity_Id; + Mark : Entity_Id := Empty; begin -- If we are generating expanded code for debugging purposes, use the -- Sloc of the point of insertion for the cleanup code. The Sloc will @@ -5703,109 +5147,22 @@ package body Exp_Ch7 is Establish_Task_Master (N); end if; - New_Decls := New_List; - -- If secondary stack is in use, generate: -- -- Mnn : constant Mark_Id := SS_Mark; if Needs_Sec_Stack_Mark then + Set_Uses_Sec_Stack (Scop, False); -- avoid duplicate SS marks Mark := Make_Temporary (Loc, 'M'); - Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark)); - Set_Uses_Sec_Stack (Scop, False); - end if; - - -- If exception handlers are present in a non-subprogram - -- construct, wrap the sequence of statements in a block. - -- Otherwise, code can be moved so that the wrong handlers - -- apply. It is important not to do this for function bodies, - -- because otherwise transient finalizable objects created - -- by a return statement get finalized too late. It is harmless - -- not to do this for procedures. - - if Present (Exception_Handlers (HSS)) - and then Nkind (N) /= N_Subprogram_Body - then - Wrap_HSS_In_Block; - - -- Ensure that the First_Real_Statement field is set - - elsif No (First_Real_Statement (HSS)) then - Set_First_Real_Statement (HSS, First (Statements (HSS))); - end if; - - -- Do not move the Activation_Chain declaration in the context of - -- task allocation blocks. Task allocation blocks use _chain in their - -- cleanup handlers and gigi complains if it is declared in the - -- sequence of statements of the scope that declares the handler. - - if Is_Task_Allocation then - declare - Chain_Decl : constant N_Object_Declaration_Id := - Parent (Activation_Chain_Entity (N)); - pragma Assert (List_Containing (Chain_Decl) = Decls); - begin - Remove (Chain_Decl); - Prepend_To (New_Decls, Chain_Decl); - end; - end if; - - -- Move the _postconditions subprogram declaration and its associated - -- objects into the declarations section so that it is callable - -- within _postconditions. - - if Has_Postcondition then declare - Decl : Node_Id; - Prev_Decl : Node_Id; - + Mark_Call : constant Node_Id := Build_SS_Mark_Call (Loc, Mark); begin - Decl := - Prev (Subprogram_Body - (Postconditions_Proc (Current_Subprogram))); - while Present (Decl) loop - Prev_Decl := Prev (Decl); - - Remove (Decl); - Prepend_To (New_Decls, Decl); - - exit when Nkind (Decl) = N_Subprogram_Declaration - and then Chars (Corresponding_Body (Decl)) - = Name_uPostconditions; - - Decl := Prev_Decl; - end loop; + Prepend_To (Decls, Mark_Call); + Analyze (Mark_Call); end; end if; - -- Ensure the presence of a declaration list in order to successfully - -- append all original statements to it. - - if No (Decls) then - Set_Declarations (N, New_List); - Decls := Declarations (N); - end if; - - -- Move the declarations into the sequence of statements in order to - -- have them protected by the At_End handler. It may seem weird to - -- put declarations in the sequence of statement but in fact nothing - -- forbids that at the tree level. - - Append_List_To (Decls, Statements (HSS)); - Set_Statements (HSS, Decls); - - -- Reset the Sloc of the handled statement sequence to properly - -- reflect the new initial "statement" in the sequence. - - Set_Sloc (HSS, Sloc (First (Decls))); - - -- The declarations of finalizer spec and auxiliary variables replace - -- the old declarations that have been moved inward. - - Set_Declarations (N, New_Decls); - Analyze_Declarations (New_Decls); - -- Generate finalization calls for all controlled objects appearing -- in the statements of N. Add context specific cleanup for various -- constructs. @@ -5814,7 +5171,7 @@ package body Exp_Ch7 is (N => N, Clean_Stmts => Build_Cleanup_Statements (N, Cln), Mark_Id => Mark, - Top_Decls => New_Decls, + Top_Decls => Decls, Defer_Abort => Nkind (Original_Node (N)) = N_Task_Body or else Is_Master, Fin_Id => Fin_Id); @@ -10103,9 +9460,6 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Loop_Copy))); - Set_First_Real_Statement - (Handled_Statement_Sequence (Local_Body), Loop_Copy); - Rewrite (Loop_Stmt, Local_Body); Analyze (Loop_Stmt); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index ed6844e..8abff55 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -26,6 +26,7 @@ with Atree; use Atree; with Aspects; use Aspects; with Checks; use Checks; +with Contracts; use Contracts; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -134,15 +135,6 @@ package body Exp_Ch9 is -- Build a specification for a function implementing the protected entry -- barrier of the specified entry body. - procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id); - -- Build the body of a wrapper procedure for an entry or entry family that - -- has contract cases, preconditions, or postconditions. The body gathers - -- the executable contract items and expands them in the usual way, and - -- performs the entry call itself. This way preconditions are evaluated - -- before the call is queued. E is the entry in question, and Decl is the - -- enclosing synchronized type declaration at whose freeze point the - -- generated body is analyzed. - function Build_Corresponding_Record (N : Node_Id; Ctyp : Entity_Id; @@ -1296,288 +1288,6 @@ package body Exp_Ch9 is Set_Master_Id (Typ, Master_Id); end Build_Class_Wide_Master; - ---------------------------- - -- Build_Contract_Wrapper -- - ---------------------------- - - procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is - Conc_Typ : constant Entity_Id := Scope (E); - Loc : constant Source_Ptr := Sloc (E); - - procedure Add_Discriminant_Renamings - (Obj_Id : Entity_Id; - Decls : List_Id); - -- Add renaming declarations for all discriminants of concurrent type - -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which - -- represents the concurrent object. - - procedure Add_Matching_Formals - (Formals : List_Id; - Actuals : in out List_Id); - -- Add formal parameters that match those of entry E to list Formals. - -- The routine also adds matching actuals for the new formals to list - -- Actuals. - - procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id); - -- Relocate pragma Prag to list To. The routine creates a new list if - -- To does not exist. - - -------------------------------- - -- Add_Discriminant_Renamings -- - -------------------------------- - - procedure Add_Discriminant_Renamings - (Obj_Id : Entity_Id; - Decls : List_Id) - is - Discr : Entity_Id; - - begin - -- Inspect the discriminants of the concurrent type and generate a - -- renaming for each one. - - if Has_Discriminants (Conc_Typ) then - Discr := First_Discriminant (Conc_Typ); - while Present (Discr) loop - Prepend_To (Decls, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars (Discr)), - Subtype_Mark => - New_Occurrence_Of (Etype (Discr), Loc), - Name => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Selector_Name => - Make_Identifier (Loc, Chars (Discr))))); - - Next_Discriminant (Discr); - end loop; - end if; - end Add_Discriminant_Renamings; - - -------------------------- - -- Add_Matching_Formals -- - -------------------------- - - procedure Add_Matching_Formals - (Formals : List_Id; - Actuals : in out List_Id) - is - Formal : Entity_Id; - New_Formal : Entity_Id; - - begin - -- Inspect the formal parameters of the entry and generate a new - -- matching formal with the same name for the wrapper. A reference - -- to the new formal becomes an actual in the entry call. - - Formal := First_Formal (E); - while Present (Formal) loop - New_Formal := Make_Defining_Identifier (Loc, Chars (Formal)); - Append_To (Formals, - Make_Parameter_Specification (Loc, - Defining_Identifier => New_Formal, - In_Present => In_Present (Parent (Formal)), - Out_Present => Out_Present (Parent (Formal)), - Parameter_Type => - New_Occurrence_Of (Etype (Formal), Loc))); - - if No (Actuals) then - Actuals := New_List; - end if; - - Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); - Next_Formal (Formal); - end loop; - end Add_Matching_Formals; - - --------------------- - -- Transfer_Pragma -- - --------------------- - - procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is - New_Prag : Node_Id; - - begin - if No (To) then - To := New_List; - end if; - - New_Prag := Relocate_Node (Prag); - - Set_Analyzed (New_Prag, False); - Append (New_Prag, To); - end Transfer_Pragma; - - -- Local variables - - Items : constant Node_Id := Contract (E); - Actuals : List_Id := No_List; - Call : Node_Id; - Call_Nam : Node_Id; - Decls : List_Id := No_List; - Formals : List_Id; - Has_Pragma : Boolean := False; - Index_Id : Entity_Id; - Obj_Id : Entity_Id; - Prag : Node_Id; - Wrapper_Id : Entity_Id; - - -- Start of processing for Build_Contract_Wrapper - - begin - -- This routine generates a specialized wrapper for a protected or task - -- entry [family] which implements precondition/postcondition semantics. - -- Preconditions and case guards of contract cases are checked before - -- the protected action or rendezvous takes place. Postconditions and - -- consequences of contract cases are checked after the protected action - -- or rendezvous takes place. The structure of the generated wrapper is - -- as follows: - - -- procedure Wrapper - -- (Obj_Id : Conc_Typ; -- concurrent object - -- [Index : Index_Typ;] -- index of entry family - -- [Formal_1 : ...; -- parameters of original entry - -- Formal_N : ...]) - -- is - -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant - -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings - - -- <precondition checks> - -- <case guard checks> - - -- procedure _Postconditions is - -- begin - -- <postcondition checks> - -- <consequence checks> - -- end _Postconditions; - - -- begin - -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]); - -- _Postconditions; - -- end Wrapper; - - -- Create the wrapper only when the entry has at least one executable - -- contract item such as contract cases, precondition or postcondition. - - if Present (Items) then - - -- Inspect the list of pre/postconditions and transfer all available - -- pragmas to the declarative list of the wrapper. - - Prag := Pre_Post_Conditions (Items); - while Present (Prag) loop - if Pragma_Name_Unmapped (Prag) in Name_Postcondition - | Name_Precondition - and then Is_Checked (Prag) - then - Has_Pragma := True; - Transfer_Pragma (Prag, To => Decls); - end if; - - Prag := Next_Pragma (Prag); - end loop; - - -- Inspect the list of test/contract cases and transfer only contract - -- cases pragmas to the declarative part of the wrapper. - - Prag := Contract_Test_Cases (Items); - while Present (Prag) loop - if Pragma_Name (Prag) = Name_Contract_Cases - and then Is_Checked (Prag) - then - Has_Pragma := True; - Transfer_Pragma (Prag, To => Decls); - end if; - - Prag := Next_Pragma (Prag); - end loop; - end if; - - -- The entry lacks executable contract items and a wrapper is not needed - - if not Has_Pragma then - return; - end if; - - -- Create the profile of the wrapper. The first formal parameter is the - -- concurrent object. - - Obj_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Conc_Typ), 'A')); - - Formals := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Obj_Id, - Out_Present => True, - In_Present => True, - Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc))); - - -- Construct the call to the original entry. The call will be gradually - -- augmented with an optional entry index and extra parameters. - - Call_Nam := - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Selector_Name => New_Occurrence_Of (E, Loc)); - - -- When creating a wrapper for an entry family, the second formal is the - -- entry index. - - if Ekind (E) = E_Entry_Family then - Index_Id := Make_Defining_Identifier (Loc, Name_I); - - Append_To (Formals, - Make_Parameter_Specification (Loc, - Defining_Identifier => Index_Id, - Parameter_Type => - New_Occurrence_Of (Entry_Index_Type (E), Loc))); - - -- The call to the original entry becomes an indexed component to - -- accommodate the entry index. - - Call_Nam := - Make_Indexed_Component (Loc, - Prefix => Call_Nam, - Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))); - end if; - - -- Add formal parameters to match those of the entry and build actuals - -- for the entry call. - - Add_Matching_Formals (Formals, Actuals); - - Call := - Make_Procedure_Call_Statement (Loc, - Name => Call_Nam, - Parameter_Associations => Actuals); - - -- Add renaming declarations for the discriminants of the enclosing type - -- as the various contract items may reference them. - - Add_Discriminant_Renamings (Obj_Id, Decls); - - Wrapper_Id := - Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E')); - Set_Contract_Wrapper (E, Wrapper_Id); - Set_Is_Entry_Wrapper (Wrapper_Id); - - -- The wrapper body is analyzed when the enclosing type is frozen - - Append_Freeze_Action (Defining_Entity (Decl), - Make_Subprogram_Body (Loc, - Specification => - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Wrapper_Id, - Parameter_Specifications => Formals), - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call)))); - end Build_Contract_Wrapper; - -------------------------------- -- Build_Corresponding_Record -- -------------------------------- @@ -3811,6 +3521,7 @@ package body Exp_Ch9 is -- Establish link between subprogram body and source entry body Set_Corresponding_Entry_Body (Proc_Body, N); + Set_At_End_Proc (Proc_Body, At_End_Proc (N)); Reset_Scopes_To (Proc_Body, Protected_Body_Subprogram (Ent)); return Proc_Body; @@ -3867,32 +3578,35 @@ package body Exp_Ch9 is Ident : Entity_Id; Unprotected : Boolean := False) return List_Id is - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; - Formal : Entity_Id; - New_Plist : List_Id; - New_Param : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + + Decl : Node_Id; + Formal : Entity_Id; + New_Formal : Entity_Id; + New_Plist : List_Id; begin New_Plist := New_List; Formal := First_Formal (Ident); while Present (Formal) loop - New_Param := + New_Formal := + Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); + Set_Comes_From_Source (New_Formal, Comes_From_Source (Formal)); + + if Unprotected then + Mutate_Ekind (New_Formal, Ekind (Formal)); + Set_Protected_Formal (Formal, New_Formal); + end if; + + Append_To (New_Plist, Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), + Defining_Identifier => New_Formal, Aliased_Present => Aliased_Present (Parent (Formal)), In_Present => In_Present (Parent (Formal)), Out_Present => Out_Present (Parent (Formal)), - Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); - - if Unprotected then - Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); - Mutate_Ekind (Defining_Identifier (New_Param), Ekind (Formal)); - end if; + Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc))); - Append (New_Param, New_Plist); Next_Formal (Formal); end loop; @@ -4021,8 +3735,7 @@ package body Exp_Ch9 is Pid : Node_Id; N_Op_Spec : Node_Id) return Node_Id is - Exc_Safe : constant Boolean := not Might_Raise (N); - -- True if N cannot raise an exception + Might_Raise : constant Boolean := Sem_Util.Might_Raise (N); Loc : constant Source_Ptr := Sloc (N); Op_Spec : constant Node_Id := Specification (N); @@ -4059,7 +3772,17 @@ package body Exp_Ch9 is -- for use by the protected version built below. if Nkind (Op_Spec) = N_Function_Specification then - if Exc_Safe then + if Might_Raise then + Unprot_Call := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + + else R := Make_Temporary (Loc, 'R'); Unprot_Call := @@ -4078,16 +3801,6 @@ package body Exp_Ch9 is Return_Stmt := Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (R, Loc)); - - else - Unprot_Call := - Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => - Make_Identifier (Loc, - Chars => Chars (Defining_Unit_Name (N_Op_Spec))), - Parameter_Associations => Uactuals)); end if; if Has_Aspect (Pid, Aspect_Exclusive_Functions) @@ -4113,7 +3826,7 @@ package body Exp_Ch9 is -- Wrap call in block that will be covered by an at_end handler - if not Exc_Safe then + if Might_Raise then Unprot_Call := Make_Block_Statement (Loc, Handled_Statement_Sequence => @@ -4160,7 +3873,7 @@ package body Exp_Ch9 is Stmts := New_List (Lock_Stmt); end if; - if not Exc_Safe then + if Might_Raise then Append (Unprot_Call, Stmts); else if Nkind (Op_Spec) = N_Function_Specification then @@ -4170,10 +3883,6 @@ package body Exp_Ch9 is Append (Unprot_Call, Stmts); end if; - -- Historical note: Previously, call to the cleanup was inserted - -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, - -- which is also shared by the 'not Exc_Safe' path. - Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); if Nkind (Op_Spec) = N_Function_Specification then @@ -4196,10 +3905,10 @@ package body Exp_Ch9 is Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); -- Mark this subprogram as a protected subprogram body so that the - -- cleanup will be inserted. This is done only in the 'not Exc_Safe' - -- path as otherwise the cleanup has already been inserted. + -- cleanup will be inserted. This is done only in the Might_Raise + -- case because otherwise the cleanup has already been inserted. - if not Exc_Safe then + if Might_Raise then Set_Is_Protected_Subprogram_Body (Sub_Body); end if; @@ -5236,7 +4945,8 @@ package body Exp_Ch9 is Specification => Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), Declarations => Decls, - Handled_Statement_Sequence => Handled_Statement_Sequence (N)); + Handled_Statement_Sequence => Handled_Statement_Sequence (N), + At_End_Proc => At_End_Proc (N)); end Build_Unprotected_Subprogram_Body; ---------------------------- @@ -8216,7 +7926,7 @@ package body Exp_Ch9 is else Transient_Blk := - First_Real_Statement (Handled_Statement_Sequence (Blk)); + First (Statements (Handled_Statement_Sequence (Blk))); if Present (Transient_Blk) and then Nkind (Transient_Blk) = N_Block_Statement @@ -9135,7 +8845,7 @@ package body Exp_Ch9 is -- Build a wrapper procedure to handle contract cases, preconditions, -- and postconditions. - Build_Contract_Wrapper (Ent_Id, N); + Build_Entry_Contract_Wrapper (Ent_Id, N); -- Create the barrier function @@ -11833,17 +11543,11 @@ package body Exp_Ch9 is if Abort_Allowed then Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); - Insert_Before - (First (Statements (Handled_Statement_Sequence (N))), Call); + Prepend (Call, Declarations (N)); Analyze (Call); end if; - -- The statement part has already been protected with an at_end and - -- cleanup actions. The call to Complete_Activation must be placed - -- at the head of the sequence of statements of that block. The - -- declarations have been merged in this sequence of statements but - -- the first real statement is accessible from the First_Real_Statement - -- field (which was set for exactly this purpose). + -- Place call to Complete_Activation at the head of the statement list. if Restricted_Profile then Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); @@ -11852,7 +11556,7 @@ package body Exp_Ch9 is end if; Insert_Before - (First_Real_Statement (Handled_Statement_Sequence (N)), Call); + (First (Statements (Handled_Statement_Sequence (N))), Call); Analyze (Call); New_N := @@ -11861,6 +11565,7 @@ package body Exp_Ch9 is Declarations => Declarations (N), Handled_Statement_Sequence => Handled_Statement_Sequence (N)); Set_Is_Task_Body_Procedure (New_N); + Set_At_End_Proc (New_N, At_End_Proc (N)); -- If the task contains generic instantiations, cleanup actions are -- delayed until after instantiation. Transfer the activation chain to @@ -12534,7 +12239,7 @@ package body Exp_Ch9 is Ent := First_Entity (Tasktyp); while Present (Ent) loop if Ekind (Ent) in E_Entry | E_Entry_Family then - Build_Contract_Wrapper (Ent, N); + Build_Entry_Contract_Wrapper (Ent, N); end if; Next_Entity (Ent); @@ -13736,6 +13441,7 @@ package body Exp_Ch9 is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Obj_Ent, Loc), Selector_Name => Make_Identifier (Loc, Name_uObject))); + Add (Decl); end; end if; @@ -13767,6 +13473,7 @@ package body Exp_Ch9 is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Obj_Ent, Loc), Selector_Name => Make_Identifier (Loc, Chars (D)))); + Add (Decl); -- Set debug info needed on this renaming declaration even @@ -13833,6 +13540,7 @@ package body Exp_Ch9 is Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Obj_Ent, Loc), Selector_Name => Make_Identifier (Loc, Nam))); + Add (Decl); end if; diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 0631172..2def83c 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -453,6 +453,8 @@ package body Exp_Prag is New_Occurrence_Of (RTE (RE_Assert_Failure), Loc)))))))); + Set_Comes_From_Check_Or_Contract (N); + -- Case where we call the procedure else @@ -541,6 +543,8 @@ package body Exp_Prag is Name => New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), Parameter_Associations => New_List (Relocate_Node (Msg)))))); + + Set_Comes_From_Check_Or_Contract (N); end if; Analyze (N); @@ -1433,6 +1437,8 @@ package body Exp_Prag is Condition => Cond, Then_Statements => New_List (Error)); + Set_Comes_From_Check_Or_Contract (Checks); + else if No (Elsif_Parts (Checks)) then Set_Elsif_Parts (Checks, New_List); @@ -1642,6 +1648,8 @@ package body Exp_Prag is Condition => New_Occurrence_Of (Flag, Loc), Then_Statements => Eval_Stmts); + Set_Comes_From_Check_Or_Contract (Evals); + -- Otherwise generate: -- elsif Flag then -- <evaluation statements> @@ -1836,6 +1844,8 @@ package body Exp_Prag is Set (Flag), Increment (Count))); + Set_Comes_From_Check_Or_Contract (If_Stmt); + Append_To (Decls, If_Stmt); Analyze (If_Stmt); @@ -1904,6 +1914,8 @@ package body Exp_Prag is Right_Opnd => Make_Integer_Literal (Loc, 0)), Then_Statements => CG_Stmts); + Set_Comes_From_Check_Or_Contract (CG_Checks); + -- Detect a possible failure due to several case guards evaluating to -- True. @@ -1937,15 +1949,17 @@ package body Exp_Prag is New_Occurrence_Of (Msg_Str, Loc)))))))))); end if; + -- Append the checks, but do not analyze them at this point, because + -- contracts get potentially expanded as part of a wrapper which gets + -- fully analyzed once it is fully formed. + Append_To (Decls, CG_Checks); - Analyze (CG_Checks); -- Once all case guards are evaluated and checked, evaluate any prefixes -- of attribute 'Old founds in the selected consequence. if Present (Old_Evals) then Append_To (Decls, Old_Evals); - Analyze (Old_Evals); end if; -- Raise Assertion_Error when the corresponding consequence of a case diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 2fb9299..9164644 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -938,7 +938,7 @@ package body Exp_Unst is -- subprogram. As above, the called entity must be local and -- not imported. - when N_Handled_Sequence_Of_Statements => + when N_Handled_Sequence_Of_Statements | N_Block_Statement => if Present (At_End_Proc (N)) and then Scope_Within (Entity (At_End_Proc (N)), Subp) and then not Is_Imported (Entity (At_End_Proc (N))) @@ -1184,6 +1184,15 @@ package body Exp_Unst is Register_Subprogram (Ent, N); + -- Record a call from an At_End_Proc + + if Present (At_End_Proc (N)) + and then Scope_Within (Entity (At_End_Proc (N)), Subp) + and then not Is_Imported (Entity (At_End_Proc (N))) + then + Append_Unique_Call ((N, Ent, Entity (At_End_Proc (N)))); + end if; + -- We make a recursive call to scan the subprogram body, so -- that we can save and restore Current_Subprogram. @@ -2583,6 +2592,8 @@ package body Exp_Unst is and then Is_Library_Level_Entity (Spec_Id) then Unnest_Subprogram (Spec_Id, N); + else + return Skip; end if; end; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 0bc22a4..61395ad 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1293,7 +1293,8 @@ package body Exp_Util is -- Gigi expects a different profile in the Secondary_Stack_Pool -- case. There must be no uses of the two missing formals -- (i.e., Pool_Param and Alignment_Param) in this case. - Formal_Params := New_List (Address_Param, Size_Param); + Formal_Params := New_List + (Address_Param, Size_Param, Alignment_Param); else Formal_Params := New_List ( Pool_Param, Address_Param, Size_Param, Alignment_Param); diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h index b002bdc..02cf105 100644 --- a/gcc/ada/fe.h +++ b/gcc/ada/fe.h @@ -217,6 +217,7 @@ extern Boolean In_Extended_Main_Code_Unit (Entity_Id); #define List_Representation_Info opt__list_representation_info #define No_Strict_Aliasing_CP opt__no_strict_aliasing #define Suppress_Checks opt__suppress_checks +#define Unnest_Subprogram_Mode opt__unnest_subprogram_mode typedef enum { Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2022, Ada_With_Extensions @@ -233,6 +234,7 @@ extern Boolean GNAT_Mode; extern Int List_Representation_Info; extern Boolean No_Strict_Aliasing_CP; extern Boolean Suppress_Checks; +extern Boolean Unnest_Subprogram_Mode; #define ZCX_Exceptions opt__zcx_exceptions #define SJLJ_Exceptions opt__sjlj_exceptions diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 52858e2..346904e 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6248,6 +6248,32 @@ package body Freeze is and then Scope (Test_E) /= Current_Scope and then Ekind (Test_E) /= E_Constant then + -- Here we deal with the special case of the expansion of + -- postconditions. Previously this was handled by the loop below, + -- since these postcondition checks got isolated to a separate, + -- internally generated, subprogram. Now, however, the postcondition + -- checks get contained within their corresponding subprogram + -- directly. + + if not Comes_From_Source (N) + and then Nkind (N) = N_Pragma + and then From_Aspect_Specification (N) + and then Is_Valid_Assertion_Kind (Original_Aspect_Pragma_Name (N)) + + -- Now, verify the placement of the pragma is within an expanded + -- subprogram which contains postcondition expansion - detected + -- through the presence of the "Wrapped_Statements" field. + + and then Present (Enclosing_Subprogram (Current_Scope)) + and then Present (Wrapped_Statements + (Enclosing_Subprogram (Current_Scope))) + then + goto Leave; + end if; + + -- Otherwise, loop through scopes checking if an enclosing scope + -- comes from source or is a generic. + declare S : Entity_Id; @@ -8330,9 +8356,9 @@ package body Freeze is -- If the parent is a subprogram body, the candidate insertion -- point is just ahead of it. - if Nkind (Parent_P) = N_Subprogram_Body - and then Unique_Defining_Entity (Parent_P) = - Freeze_Outside_Subp + if Nkind (Parent_P) = N_Subprogram_Body + and then Unique_Defining_Entity (Parent_P) = + Freeze_Outside_Subp then P := Parent_P; exit; diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc index 96ea13e..c5a93fb 100644 --- a/gcc/ada/gcc-interface/decl.cc +++ b/gcc/ada/gcc-interface/decl.cc @@ -436,7 +436,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If this is a numeric or enumeral type, or an access type, a nonzero Esize must be specified unless it was specified by the programmer. Exceptions are for access-to-protected-subprogram types and all access subtypes, as - another GNAT type is used to lay out the GCC type for them. */ + another GNAT type is used to lay out the GCC type for them, as well as + access-to-subprogram types if front-end unnesting is enabled. */ gcc_assert (!is_type || Known_Esize (gnat_entity) || Has_Size_Clause (gnat_entity) @@ -445,6 +446,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && (!IN (kind, Access_Kind) || kind == E_Access_Protected_Subprogram_Type || kind == E_Anonymous_Access_Protected_Subprogram_Type + || ((kind == E_Access_Subprogram_Type + || kind == E_Anonymous_Access_Subprogram_Type) + && Unnest_Subprogram_Mode) || kind == E_Access_Subtype || type_annotate_only))); @@ -5602,6 +5606,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first, gnu_param = create_param_decl (gnu_param_name, gnu_param_type); TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr; + DECL_ARTIFICIAL (gnu_param) = !Comes_From_Source (gnat_param); DECL_BY_REF_P (gnu_param) = by_ref; DECL_FORCED_BY_REF_P (gnu_param) = forced_by_ref; DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index c1dd567..f2e0cb2 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -234,7 +234,7 @@ static inline bool stmt_group_may_fallthru (void); static enum gimplify_status gnat_gimplify_stmt (tree *); static void elaborate_all_entities (Node_Id); static void process_freeze_entity (Node_Id); -static void process_decls (List_Id, List_Id, Node_Id, bool, bool); +static void process_decls (List_Id, List_Id, bool, bool); static tree emit_check (tree, tree, int, Node_Id); static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id); static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id); @@ -1088,6 +1088,28 @@ Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type) return false; } +/* Return the full view of a private constant E, or of a renaming thereof, if + its type has discriminants, and Empty otherwise. */ + +static Entity_Id +Full_View_Of_Private_Constant (Entity_Id E) +{ + while (Present (Renamed_Object (E)) && Is_Entity_Name (Renamed_Object (E))) + E = Entity (Renamed_Object (E)); + + if (Ekind (E) != E_Constant || No (Full_View (E))) + return Empty; + + const Entity_Id T = Etype (E); + + if (Is_Private_Type (T) + && (Has_Unknown_Discriminants (T) + || (Present (Full_View (T)) && Has_Discriminants (Full_View (T))))) + return Full_View (E); + + return Empty; +} + /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Identifier, to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should place the result type. */ @@ -1095,21 +1117,19 @@ Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type) static tree Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) { - /* The entity of GNAT_NODE and its type. */ - Node_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier - || Nkind (gnat_node) == N_Defining_Operator_Symbol) - ? gnat_node : Entity (gnat_node); - Node_Id gnat_entity_type = Etype (gnat_entity); + Entity_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier + || Nkind (gnat_node) == N_Defining_Operator_Symbol) + ? gnat_node : Entity (gnat_node); + Entity_Id gnat_result_type; + tree gnu_result, gnu_result_type; /* If GNAT_NODE is a constant, whether we should use the initialization value instead of the constant entity, typically for scalars with an address clause when the parent doesn't require an lvalue. */ - bool use_constant_initializer = false; + bool use_constant_initializer; /* Whether we should require an lvalue for GNAT_NODE. Needed in specific circumstances only, so evaluated lazily. < 0 means unknown, > 0 means known true, 0 means known false. */ - int require_lvalue = -1; - Entity_Id gnat_result_type; - tree gnu_result, gnu_result_type; + int require_lvalue; /* If the Etype of this node is not the same as that of the Entity, then something went wrong, probably in generic instantiation. However, this @@ -1118,25 +1138,17 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */ gcc_assert (!Is_Object (gnat_entity) || Ekind (gnat_entity) == E_Discriminant - || Etype (gnat_node) == gnat_entity_type - || Gigi_Types_Compatible (Etype (gnat_node), gnat_entity_type)); + || Etype (gnat_node) == Etype (gnat_entity) + || Gigi_Types_Compatible (Etype (gnat_node), + Etype (gnat_entity))); - /* If this is a reference to a deferred constant whose partial view is an + /* If this is a reference to a deferred constant whose partial view is of unconstrained private type, the proper type is on the full view of the - constant, not on the full view of the type, which may be unconstrained. - - This may be a reference to a type, for example in the prefix of the - attribute Position, generated for dispatching code (see Make_DT in - exp_disp,adb). In that case we need the type itself, not is parent, - in particular if it is a derived type */ - if (Ekind (gnat_entity) == E_Constant - && Is_Private_Type (gnat_entity_type) - && (Has_Unknown_Discriminants (gnat_entity_type) - || (Present (Full_View (gnat_entity_type)) - && Has_Discriminants (Full_View (gnat_entity_type)))) - && Present (Full_View (gnat_entity))) + constant, not on the full view of the type which may be unconstrained. */ + const Entity_Id gnat_full_view = Full_View_Of_Private_Constant (gnat_entity); + if (Present (gnat_full_view)) { - gnat_entity = Full_View (gnat_entity); + gnat_entity = gnat_full_view; gnat_result_type = Etype (gnat_entity); } else @@ -1184,7 +1196,13 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) = lvalue_required_p (gnat_node, gnu_result_type, true, false); use_constant_initializer = !require_lvalue; } + else + { + require_lvalue = -1; + use_constant_initializer = false; + } + /* Fetch the initialization value of a constant if requested. */ if (use_constant_initializer) { /* If this is a deferred constant, the initializer is attached to @@ -3778,6 +3796,39 @@ build_return_expr (tree ret_obj, tree ret_val) return build1 (RETURN_EXPR, void_type_node, result_expr); } +/* Subroutine of gnat_to_gnu to translate the At_End_Proc of GNAT_NODE, an + N_Block_Statement or N_Handled_Sequence_Of_Statements or N_*_Body node. + + To invoked the GCC mechanism, we call add_cleanup and when we leave the + group, end_stmt_group will create the TRY_FINALLY_EXPR construct. */ + +static void +At_End_Proc_to_gnu (Node_Id gnat_node) +{ + tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node)); + Node_Id gnat_end_label; + + /* When not optimizing, disable inlining of finalizers as this can + create a more complex CFG in the parent function. */ + if (!optimize || optimize_debug) + DECL_DECLARED_INLINE_P (proc_decl) = 0; + + /* Retrieve the end label attached to the node, if any. */ + if (Nkind (gnat_node) == N_Handled_Sequence_Of_Statements) + gnat_end_label = End_Label (gnat_node); + else if (Present (Handled_Statement_Sequence (gnat_node))) + gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); + else + gnat_end_label = Empty; + + /* If there is no end label attached, we use the location of the At_End + procedure because Expand_Cleanup_Actions might reset the location of + the enclosing construct to that of an inner statement. */ + add_cleanup (build_call_n_expr (proc_decl, 0), + Present (gnat_end_label) + ? gnat_end_label : At_End_Proc (gnat_node)); +} + /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Subprogram_Body. */ static void @@ -3928,12 +3979,16 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) gnat_pushlevel (); /* First translate the declarations of the subprogram. */ - process_decls (Declarations (gnat_node), Empty, Empty, true, true); + process_decls (Declarations (gnat_node), Empty, true, true); /* Then generate the code of the subprogram itself. A return statement will be present and any Out parameters will be handled there. */ add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + /* Process the At_End_Proc, if any. */ + if (Present (At_End_Proc (gnat_node))) + At_End_Proc_to_gnu (gnat_node); + gnat_poplevel (); tree gnu_result = end_stmt_group (); @@ -5305,76 +5360,39 @@ static tree Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) { /* If just annotating, ignore all EH and cleanups. */ - const bool gcc_eh + const bool eh = !type_annotate_only && Present (Exception_Handlers (gnat_node)); const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); - const bool binding_for_block = (at_end || gcc_eh); - tree gnu_inner_block; /* The statement(s) for the block itself. */ tree gnu_result; Node_Id gnat_temp; - /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes. - To call the GCC mechanism, we call add_cleanup, and when we leave the - binding, end_stmt_group will create the TRY_FINALLY_EXPR construct. + /* The exception handling mechanism can handle both ZCX and SJLJ schemes, and + is exposed through the TRY_CATCH_EXPR construct that we build manually. ??? The region level calls down there have been specifically put in place for a ZCX context and currently the order in which things are emitted (region/handlers) is different from the SJLJ case. Instead of putting other calls with different conditions at other places for the SJLJ case, it seems cleaner to reorder things for the SJLJ case and generalize the - condition to make it not ZCX specific. - - If there are any exceptions or cleanup processing involved, we need an - outer statement group and binding level. */ - if (binding_for_block) - { - start_stmt_group (); - gnat_pushlevel (); - } - - /* If we are to call a function when exiting this block, add a cleanup - to the binding level we made above. Note that add_cleanup is FIFO - so we must register this cleanup after the EH cleanup just above. */ - if (at_end) - { - tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node)); - - /* When not optimizing, disable inlining of finalizers as this can - create a more complex CFG in the parent function. */ - if (!optimize || optimize_debug) - DECL_DECLARED_INLINE_P (proc_decl) = 0; - - /* If there is no end label attached, we use the location of the At_End - procedure because Expand_Cleanup_Actions might reset the location of - the enclosing construct to that of an inner statement. */ - add_cleanup (build_call_n_expr (proc_decl, 0), - Present (End_Label (gnat_node)) - ? End_Label (gnat_node) : At_End_Proc (gnat_node)); - } + condition to make it not ZCX specific. */ - /* Now build the tree for the declarations and statements inside this - block. */ + /* First build the tree for the statements inside the sequence. */ start_stmt_group (); - if (Present (First_Real_Statement (gnat_node))) - process_decls (Statements (gnat_node), Empty, - First_Real_Statement (gnat_node), true, true); - - /* Generate code for each statement in the block. */ - for (gnat_temp = (Present (First_Real_Statement (gnat_node)) - ? First_Real_Statement (gnat_node) - : First (Statements (gnat_node))); - Present (gnat_temp); gnat_temp = Next (gnat_temp)) + for (gnat_temp = First (Statements (gnat_node)); + Present (gnat_temp); + gnat_temp = Next (gnat_temp)) add_stmt (gnat_to_gnu (gnat_temp)); - gnu_inner_block = end_stmt_group (); + gnu_result = end_stmt_group (); - if (gcc_eh) + /* Then process the exception handlers, if any. */ + if (eh) { tree gnu_handlers; location_t locus; - /* First make a block containing the handlers. */ + /* First make a group containing the handlers. */ start_stmt_group (); for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); Present (gnat_temp); @@ -5382,9 +5400,10 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) add_stmt (gnat_to_gnu (gnat_temp)); gnu_handlers = end_stmt_group (); - /* Now make the TRY_CATCH_EXPR for the block. */ - gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, - gnu_inner_block, gnu_handlers); + /* Now make the TRY_CATCH_EXPR for the group. */ + gnu_result + = build2 (TRY_CATCH_EXPR, void_type_node, gnu_result, gnu_handlers); + /* Set a location. We need to find a unique location for the dispatching code, otherwise we can get coverage or debugging issues. Try with the location of the end label. */ @@ -5398,14 +5417,13 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) coverage analysis tools. */ set_expr_location_from_node (gnu_result, gnat_node, true); } - else - gnu_result = gnu_inner_block; - /* Now close our outer block, if we had to make one. */ - if (binding_for_block) + /* Process the At_End_Proc, if any. */ + if (at_end) { + start_stmt_group (); add_stmt (gnu_result); - gnat_poplevel (); + At_End_Proc_to_gnu (gnat_node); gnu_result = end_stmt_group (); } @@ -5493,7 +5511,6 @@ Exception_Handler_to_gnu (Node_Id gnat_node) } start_stmt_group (); - gnat_pushlevel (); /* Expand a call to the begin_handler hook at the beginning of the handler, and arrange for a call to the end_handler hook to occur @@ -5584,7 +5601,7 @@ Exception_Handler_to_gnu (Node_Id gnat_node) else { start_stmt_group (); - gnat_pushlevel (); + /* CODE: void *EXPRP = __builtin_eh_handler (0); */ tree prop_ptr = create_var_decl (get_identifier ("EXPRP"), NULL_TREE, @@ -5604,14 +5621,11 @@ Exception_Handler_to_gnu (Node_Id gnat_node) add_stmt_with_node (ecall, gnat_node); /* CODE: } */ - gnat_poplevel (); tree eblk = end_stmt_group (); tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk); add_cleanup (ehls, gnat_node); } - gnat_poplevel (); - gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr; return @@ -5677,7 +5691,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) gnat_pragma = Next (gnat_pragma)) if (Nkind (gnat_pragma) == N_Pragma) add_stmt (gnat_to_gnu (gnat_pragma)); - process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty, + process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, true, true); /* Process the unit itself. */ @@ -6877,6 +6891,11 @@ gnat_to_gnu (Node_Id gnat_node) : (Rounded_Result (gnat_node) ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR), gnu_result_type, gnu_lhs, gnu_rhs); + /* If the result type is larger than a word, then declare the dependence + on the libgcc routine. */ + if (INTEGRAL_TYPE_P (gnu_result_type) + && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); break; case N_Op_Eq: @@ -6936,6 +6955,10 @@ gnat_to_gnu (Node_Id gnat_node) gnu_rhs = convert (gnu_count_type, gnu_rhs); gnu_max_shift = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type)); + /* If the result type is larger than a word, then declare the dependence + on the libgcc routine. */ + if (TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); } /* If this is a comparison between (potentially) large aggregates, then @@ -6948,6 +6971,12 @@ gnat_to_gnu (Node_Id gnat_node) Check_Restriction_No_Dependence_On_System (Name_Memory_Compare, gnat_node); + /* If this is a modulo/remainder and the result type is larger than a + word, then declare the dependence on the libgcc routine. */ + else if ((kind == N_Op_Mod ||kind == N_Op_Rem) + && TYPE_PRECISION (gnu_result_type) > BITS_PER_WORD) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); + /* Pending generic support for efficient vector logical operations in GCC, convert vectors to their representative array type view. */ gnu_lhs = maybe_vector_array (gnu_lhs); @@ -7365,8 +7394,10 @@ gnat_to_gnu (Node_Id gnat_node) { start_stmt_group (); gnat_pushlevel (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); + process_decls (Declarations (gnat_node), Empty, true, true); add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); + if (Present (At_End_Proc (gnat_node))) + At_End_Proc_to_gnu (gnat_node); gnat_poplevel (); gnu_result = end_stmt_group (); } @@ -7606,15 +7637,14 @@ gnat_to_gnu (Node_Id gnat_node) break; case N_Package_Specification: - start_stmt_group (); process_decls (Visible_Declarations (gnat_node), - Private_Declarations (gnat_node), Empty, true, true); + Private_Declarations (gnat_node), + true, true); gnu_result = end_stmt_group (); break; case N_Package_Body: - /* If this is the body of a generic package - do nothing. */ if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package) { @@ -7623,11 +7653,11 @@ gnat_to_gnu (Node_Id gnat_node) } start_stmt_group (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); - + process_decls (Declarations (gnat_node), Empty, true, true); if (Present (Handled_Statement_Sequence (gnat_node))) add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); - + if (Present (At_End_Proc (gnat_node))) + At_End_Proc_to_gnu (gnat_node); gnu_result = end_stmt_group (); break; @@ -7673,7 +7703,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Task_Body: /* These nodes should only be present when annotating types. */ gcc_assert (type_annotate_only); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); + process_decls (Declarations (gnat_node), Empty, true, true); gnu_result = alloc_stmt_list (); break; @@ -7975,7 +8005,7 @@ gnat_to_gnu (Node_Id gnat_node) case N_Freeze_Entity: start_stmt_group (); process_freeze_entity (gnat_node); - process_decls (Actions (gnat_node), Empty, Empty, true, true); + process_decls (Actions (gnat_node), Empty, true, true); gnu_result = end_stmt_group (); break; @@ -9203,17 +9233,13 @@ process_freeze_entity (Node_Id gnat_node) we declare a function if there was no spec). The second pass elaborates the bodies. - GNAT_END_LIST gives the element in the list past the end. Normally, - this is Empty, but can be First_Real_Statement for a - Handled_Sequence_Of_Statements. - We make a complete pass through both lists if PASS1P is true, then make the second pass over both lists if PASS2P is true. The lists usually correspond to the public and private parts of a package. */ static void process_decls (List_Id gnat_decls, List_Id gnat_decls2, - Node_Id gnat_end_list, bool pass1p, bool pass2p) + bool pass1p, bool pass2p) { List_Id gnat_decl_array[2]; Node_Id gnat_decl; @@ -9225,7 +9251,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, for (i = 0; i <= 1; i++) if (Present (gnat_decl_array[i])) for (gnat_decl = First (gnat_decl_array[i]); - gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + Present (gnat_decl); + gnat_decl = Next (gnat_decl)) { /* For package specs, we recurse inside the declarations, thus taking the two pass approach inside the boundary. */ @@ -9234,14 +9261,14 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, == N_Package_Specification))) process_decls (Visible_Declarations (Specification (gnat_decl)), Private_Declarations (Specification (gnat_decl)), - Empty, true, false); + true, false); /* Similarly for any declarations in the actions of a freeze node. */ else if (Nkind (gnat_decl) == N_Freeze_Entity) { process_freeze_entity (gnat_decl); - process_decls (Actions (gnat_decl), Empty, Empty, true, false); + process_decls (Actions (gnat_decl), Empty, true, false); } /* Package bodies with freeze nodes get their elaboration deferred @@ -9308,7 +9335,8 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, for (i = 0; i <= 1; i++) if (Present (gnat_decl_array[i])) for (gnat_decl = First (gnat_decl_array[i]); - gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) + Present (gnat_decl); + gnat_decl = Next (gnat_decl)) { if (Nkind (gnat_decl) == N_Subprogram_Body || Nkind (gnat_decl) == N_Subprogram_Body_Stub @@ -9321,10 +9349,10 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2, == N_Package_Specification))) process_decls (Visible_Declarations (Specification (gnat_decl)), Private_Declarations (Specification (gnat_decl)), - Empty, false, true); + false, true); else if (Nkind (gnat_decl) == N_Freeze_Entity) - process_decls (Actions (gnat_decl), Empty, Empty, false, true); + process_decls (Actions (gnat_decl), Empty, false, true); else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration) add_stmt (gnat_to_gnu (gnat_decl)); @@ -9763,6 +9791,16 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p, else gnu_result = convert (gnu_base_type, gnu_result); + /* If this is a conversion between an integer type larger than a word and a + floating-point type, then declare the dependence on the libgcc routine. */ + if ((INTEGRAL_TYPE_P (gnu_in_base_type) + && TYPE_PRECISION (gnu_in_base_type) > BITS_PER_WORD + && FLOAT_TYPE_P (gnu_base_type)) + || (FLOAT_TYPE_P (gnu_in_base_type) + && INTEGRAL_TYPE_P (gnu_base_type) + && TYPE_PRECISION (gnu_base_type) > BITS_PER_WORD)) + Check_Restriction_No_Dependence_On_System (Name_Gcc, gnat_node); + return convert (gnu_type, gnu_result); } @@ -10389,7 +10427,6 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); else gnat_end_label = Empty; - break; case N_Package_Declaration: @@ -10410,7 +10447,7 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) transient block does not receive the sloc of a source condition. */ if (!Sloc_to_locus (Sloc (gnat_node), &end_locus, No (gnat_end_label) - && (Nkind (gnat_node) == N_Block_Statement))) + && Nkind (gnat_node) == N_Block_Statement)) return false; switch (TREE_CODE (gnu_node)) diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc index a571430..3d4c1c1 100644 --- a/gcc/ada/gcc-interface/utils.cc +++ b/gcc/ada/gcc-interface/utils.cc @@ -868,6 +868,13 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) } } +/* Pointer types aren't named types in the C sense so we need to generate a + typedef in DWARF for them. Also do that for fat pointer types because, + even though they are named types in the C sense, they are still the XUP + types created for the base array type at this point. */ +#define TYPE_IS_POINTER_P(NODE) \ + (TREE_CODE (NODE) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (NODE)) + /* For the declaration of a type, set its name either if it isn't already set or if the previous type name was not derived from a source name. We'd rather have the type named with a real name and all the pointer @@ -877,18 +884,14 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) { tree t = TREE_TYPE (decl); - /* Pointer types aren't named types in the C sense so we need to generate - a typedef in DWARF for them and make sure it is preserved, unless the - type is artificial. */ + /* For pointer types, make sure the typedef is generated and preserved + in DWARF, unless the type is artificial. */ if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL) - && (TREE_CODE (t) != POINTER_TYPE || DECL_ARTIFICIAL (decl))) + && (!TYPE_IS_POINTER_P (t) || DECL_ARTIFICIAL (decl))) ; /* For pointer types, create the DECL_ORIGINAL_TYPE that will generate - the typedef in DWARF. Also do that for fat pointer types because, - even though they are named types in the C sense, they are still the - XUP types created for the base array type at this point. */ - else if (!DECL_ARTIFICIAL (decl) - && (TREE_CODE (t) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (t))) + the typedef in DWARF. */ + else if (TYPE_IS_POINTER_P (t) && !DECL_ARTIFICIAL (decl)) { tree tt = build_variant_type_copy (t); TYPE_NAME (tt) = decl; @@ -920,9 +923,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) to all parallel types too thanks to gnat_set_type_context. */ if (t) for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) - /* ??? Because of the previous kludge, we can have variants of fat - pointer types with different names. */ - if (!(TYPE_IS_FAT_POINTER_P (t) + /* Skip it for pointer types to preserve the typedef. */ + if (!(TYPE_IS_POINTER_P (t) && TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) { @@ -932,6 +934,8 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) deferred_decl_context); } } + +#undef TYPE_IS_POINTER_P } /* Create a record type that contains a SIZE bytes long field of TYPE with a diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index c6bcb71..83c7180 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -96,6 +96,7 @@ package Gen_IL.Fields is Class_Present, Classifications, Cleanup_Actions, + Comes_From_Check_Or_Contract, Comes_From_Extended_Return_Statement, Compile_Time_Known_Aggregate, Component_Associations, @@ -183,7 +184,6 @@ package Gen_IL.Fields is First_Inlined_Subprogram, First_Name, First_Named_Actual, - First_Real_Statement, First_Subtype_Link, Float_Truncate, Formal_Type_Definition, @@ -930,7 +930,8 @@ package Gen_IL.Fields is Warnings_Off_Used_Unmodified, Warnings_Off_Used_Unreferenced, Was_Hidden, - Wrapped_Entity + Wrapped_Entity, + Wrapped_Statements -- End of entity fields. ); -- Opt_Field_Enum diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 89d8659..2e1e3c9 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -1046,7 +1046,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Thunk_Entity, Node_Id, Pre => "Is_Thunk (N)"), Sm (Wrapped_Entity, Node_Id, - Pre => "Is_Primitive_Wrapper (N)"))); + Pre => "Is_Primitive_Wrapper (N)"), + Sm (Wrapped_Statements, Node_Id))); Cc (E_Operator, Subprogram_Kind, -- A predefined operator, appearing in Standard, or an implicitly @@ -1095,7 +1096,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Thunk_Entity, Node_Id, Pre => "Is_Thunk (N)"), Sm (Wrapped_Entity, Node_Id, - Pre => "Is_Primitive_Wrapper (N)"))); + Pre => "Is_Primitive_Wrapper (N)"), + Sm (Wrapped_Statements, Node_Id))); Cc (E_Abstract_State, Overloadable_Kind, -- A state abstraction. Used to designate entities introduced by aspect @@ -1134,7 +1136,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Protection_Object, Node_Id), Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), - Sm (SPARK_Pragma_Inherited, Flag))); + Sm (SPARK_Pragma_Inherited, Flag), + Sm (Wrapped_Statements, Node_Id))); Cc (E_Entry_Family, Entity_Kind, -- An entry family, created by an entry family declaration in a @@ -1161,7 +1164,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Renamed_Or_Alias, Node_Id), Sm (Scope_Depth_Value, Unat), Sm (SPARK_Pragma, Node_Id), - Sm (SPARK_Pragma_Inherited, Flag))); + Sm (SPARK_Pragma_Inherited, Flag), + Sm (Wrapped_Statements, Node_Id))); Cc (E_Block, Entity_Kind, -- A block identifier, created by an explicit or implicit label on diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index 97c16bc..556326a 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -804,13 +804,15 @@ begin -- Gen_IL.Gen.Gen_Nodes Cc (N_Package_Body, N_Unit_Body, (Sy (Defining_Unit_Name, Node_Id), Sy (Declarations, List_Id, Default_No_List), - Sy (Handled_Statement_Sequence, Node_Id, Default_Empty))); + Sy (Handled_Statement_Sequence, Node_Id, Default_Empty), + Sy (At_End_Proc, Node_Id, Default_Empty))); Cc (N_Subprogram_Body, N_Unit_Body, (Sy (Specification, Node_Id), Sy (Declarations, List_Id, Default_No_List), Sy (Handled_Statement_Sequence, Node_Id, Default_Empty), Sy (Bad_Is_Detected, Flag), + Sy (At_End_Proc, Node_Id, Default_Empty), Sm (Activation_Chain_Entity, Node_Id), Sm (Acts_As_Spec, Flag), Sm (Corresponding_Entry_Body, Node_Id), @@ -832,6 +834,7 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Defining_Identifier, Node_Id), Sy (Declarations, List_Id, Default_No_List), Sy (Handled_Statement_Sequence, Node_Id, Default_Empty), + Sy (At_End_Proc, Node_Id, Default_Empty), Sm (Activation_Chain_Entity, Node_Id), Sm (Is_Task_Master, Flag))); @@ -975,6 +978,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Has_Created_Identifier, Flag), Sy (Is_Asynchronous_Call_Block, Flag), Sy (Is_Task_Allocation_Block, Flag), + Sy (At_End_Proc, Node_Id, Default_Empty), Sm (Activation_Chain_Entity, Node_Id), Sm (Cleanup_Actions, List_Id), Sm (Exception_Junk, Flag), @@ -1094,7 +1098,8 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Elsif_Parts, List_Id, Default_No_List), Sy (Else_Statements, List_Id, Default_No_List), Sy (End_Span, Unat, Default_Uint_0), - Sm (From_Conditional_Expression, Flag))); + Sm (From_Conditional_Expression, Flag), + Sm (Comes_From_Check_Or_Contract, Flag))); Cc (N_Accept_Alternative, Node_Kind, (Sy (Accept_Statement, Node_Id), @@ -1334,6 +1339,7 @@ begin -- Gen_IL.Gen.Gen_Nodes Sy (Entry_Body_Formal_Part, Node_Id), Sy (Declarations, List_Id, Default_No_List), Sy (Handled_Statement_Sequence, Node_Id, Default_Empty), + Sy (At_End_Proc, Node_Id, Default_Empty), Sm (Activation_Chain_Entity, Node_Id))); Cc (N_Entry_Call_Alternative, Node_Kind, @@ -1421,8 +1427,7 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Statements, List_Id, Default_Empty_List), Sy (End_Label, Node_Id, Default_Empty), Sy (Exception_Handlers, List_Id, Default_No_List), - Sy (At_End_Proc, Node_Id, Default_Empty), - Sm (First_Real_Statement, Node_Id))); + Sy (At_End_Proc, Node_Id, Default_Empty))); Cc (N_Index_Or_Discriminant_Constraint, Node_Kind, (Sy (Constraints, List_Id))); diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 1ce1d6a..0f03285 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -271,11 +271,11 @@ package body Ghost is if Present (Subp_Id) then - -- The context is the internally built _Postconditions + -- The context is the internally built _Wrapped_Statements -- procedure, which is OK because the real check was done - -- before expansion activities. + -- before contract expansion activities. - if Chars (Subp_Id) = Name_uPostconditions then + if Chars (Subp_Id) = Name_uWrapped_Statements then return True; -- The context is the internally built predicate function, @@ -432,9 +432,7 @@ package body Ghost is -- but it may still contain references to Ghost entities. elsif Nkind (Stmt) = N_If_Statement - and then Nkind (Original_Node (Stmt)) = N_Pragma - and then Assertion_Expression_Pragma - (Get_Pragma_Id (Original_Node (Stmt))) + and then Comes_From_Check_Or_Contract (Stmt) then return True; end if; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index fe2f434..cdf8605 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT Reference Manual , Aug 25, 2022 +GNAT Reference Manual , Sep 09, 2022 AdaCore @@ -398,7 +398,6 @@ Implementation Defined Attributes * Attribute Iterable:: * Attribute Large:: * Attribute Library_Level:: -* Attribute Lock_Free:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -694,17 +693,6 @@ The GNAT Library * Ada.Characters.Wide_Latin_9 (a-cwila1.ads): Ada Characters Wide_Latin_9 a-cwila1 ads. * Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads): Ada Characters Wide_Wide_Latin_1 a-chzla1 ads. * Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads): Ada Characters Wide_Wide_Latin_9 a-chzla9 ads. -* Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads): Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads. -* Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads): Ada Containers Formal_Hashed_Maps a-cfhama ads. -* Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads): Ada Containers Formal_Hashed_Sets a-cfhase ads. -* Ada.Containers.Formal_Ordered_Maps (a-cforma.ads): Ada Containers Formal_Ordered_Maps a-cforma ads. -* Ada.Containers.Formal_Ordered_Sets (a-cforse.ads): Ada Containers Formal_Ordered_Sets a-cforse ads. -* Ada.Containers.Formal_Vectors (a-cofove.ads): Ada Containers Formal_Vectors a-cofove ads. -* Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads): Ada Containers Formal_Indefinite_Vectors a-cfinve ads. -* Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads): Ada Containers Functional_Infinite_Sequences a-cfinse ads. -* Ada.Containers.Functional_Vectors (a-cofuve.ads): Ada Containers Functional_Vectors a-cofuve ads. -* Ada.Containers.Functional_Sets (a-cofuse.ads): Ada Containers Functional_Sets a-cofuse ads. -* Ada.Containers.Functional_Maps (a-cofuma.ads): Ada Containers Functional_Maps a-cofuma ads. * Ada.Containers.Bounded_Holders (a-coboho.ads): Ada Containers Bounded_Holders a-coboho ads. * Ada.Command_Line.Environment (a-colien.ads): Ada Command_Line Environment a-colien ads. * Ada.Command_Line.Remove (a-colire.ads): Ada Command_Line Remove a-colire ads. @@ -3717,7 +3705,8 @@ set shall be a proper subset of the second (and the later alternative will not be executed if the earlier alternative “matches”). All possible values of the composite type shall be covered. The composite type of the selector shall be an array or record type that is neither limited -class-wide. +class-wide. Currently, a “when others =>” case choice is required; it is +intended that this requirement will be relaxed at some point. If a subcomponent’s subtype does not meet certain restrictions, then the only value that can be specified for that subcomponent in a case @@ -5273,6 +5262,12 @@ May not dereferenced access values Function calls and attribute references must be static @end itemize +If the Lock_Free aspect is specified to be True for a protected unit +and the Ceiling_Locking locking policy is in effect, then the run-time +actions associated with the Ceiling_Locking locking policy (described in +Ada RM D.3) are not performed when a protected operation of the protected +unit is executed. + @node Pragma Loop_Invariant,Pragma Loop_Optimize,Pragma Lock_Free,Implementation Defined Pragmas @anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{95} @section Pragma Loop_Invariant @@ -8662,7 +8657,7 @@ be. For the variable case, warnings are never given for unreferenced variables whose name contains one of the substrings -@code{DISCARD, DUMMY, IGNORE, JUNK, UNUSED} in any casing. Such names +@code{DISCARD, DUMMY, IGNORE, JUNK, UNUSE, TMP, TEMP} in any casing. Such names are typically to be used in cases where such warnings are expected. Thus it is never necessary to use @code{pragma Unmodified} for such variables, though it is harmless to do so. @@ -9774,33 +9769,37 @@ The following is a typical example of use: type List is private with Iterable => (First => First_Cursor, Next => Advance, - Has_Element => Cursor_Has_Element, - [Element => Get_Element]); + Has_Element => Cursor_Has_Element + [,Element => Get_Element] + [,Last => Last_Cursor] + [,Previous => Retreat]); @end example @itemize * @item -The value denoted by @code{First} must denote a primitive operation of the -container type that returns a @code{Cursor}, which must a be a type declared in +The values of @code{First} and @code{Last} are primitive operations of the +container type that return a @code{Cursor}, which must be a type declared in the container package or visible from it. For example: @end itemize @example function First_Cursor (Cont : Container) return Cursor; +function Last_Cursor (Cont : Container) return Cursor; @end example @itemize * @item -The value of @code{Next} is a primitive operation of the container type that takes -both a container and a cursor and yields a cursor. For example: +The values of @code{Next} and @code{Previous} are primitive operations of the container type that take +both a container and a cursor and yield a cursor. For example: @end itemize @example function Advance (Cont : Container; Position : Cursor) return Cursor; +function Retreat (Cont : Container; Position : Cursor) return Cursor; @end example @@ -10261,7 +10260,6 @@ consideration, you should minimize the use of these attributes. * Attribute Iterable:: * Attribute Large:: * Attribute Library_Level:: -* Attribute Lock_Free:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -10973,7 +10971,7 @@ The @code{Large} attribute is provided for compatibility with Ada 83. See the Ada 83 reference manual for an exact description of the semantics of this attribute. -@node Attribute Library_Level,Attribute Lock_Free,Attribute Large,Implementation Defined Attributes +@node Attribute Library_Level,Attribute Loop_Entry,Attribute Large,Implementation Defined Attributes @anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{188} @section Attribute Library_Level @@ -10999,18 +10997,8 @@ package Gen is end Gen; @end example -@node Attribute Lock_Free,Attribute Loop_Entry,Attribute Library_Level,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{189} -@section Attribute Lock_Free - - -@geindex Lock_Free - -@code{P'Lock_Free}, where P is a protected object, returns True if a -pragma @code{Lock_Free} applies to P. - -@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Lock_Free,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{18a} +@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Library_Level,Implementation Defined Attributes +@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{189} @section Attribute Loop_Entry @@ -11043,7 +11031,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{18b} +@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{18a} @section Attribute Machine_Size @@ -11053,7 +11041,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{18c} +@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{18b} @section Attribute Mantissa @@ -11066,7 +11054,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{18d}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18e} +@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{18c}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{18d} @section Attribute Maximum_Alignment @@ -11082,7 +11070,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{18f} +@anchor{gnat_rm/implementation_defined_attributes attribute-max-integer-size}@anchor{18e} @section Attribute Max_Integer_Size @@ -11093,7 +11081,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{190} +@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{18f} @section Attribute Mechanism_Code @@ -11124,7 +11112,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{191} +@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{190} @section Attribute Null_Parameter @@ -11149,7 +11137,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{141}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{192} +@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{141}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{191} @section Attribute Object_Size @@ -11219,7 +11207,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{193} +@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{192} @section Attribute Old @@ -11234,7 +11222,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{194} +@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{193} @section Attribute Passed_By_Reference @@ -11250,7 +11238,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{195} +@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{194} @section Attribute Pool_Address @@ -11272,7 +11260,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{196} +@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{195} @section Attribute Range_Length @@ -11285,7 +11273,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{197} +@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{196} @section Attribute Restriction_Set @@ -11355,7 +11343,7 @@ Restrictions pragma, they are not analyzed semantically, so they do not have a type. @node Attribute Result,Attribute Safe_Emax,Attribute Restriction_Set,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{198} +@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{197} @section Attribute Result @@ -11368,7 +11356,7 @@ For a further discussion of the use of this attribute and examples of its use, see the description of pragma Postcondition. @node Attribute Safe_Emax,Attribute Safe_Large,Attribute Result,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{199} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{198} @section Attribute Safe_Emax @@ -11381,7 +11369,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{19a} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{199} @section Attribute Safe_Large @@ -11394,7 +11382,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{19b} +@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{19a} @section Attribute Safe_Small @@ -11407,7 +11395,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{14f}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19c} +@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{14f}@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{19b} @section Attribute Scalar_Storage_Order @@ -11570,7 +11558,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{e4}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19d} +@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{e4}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{19c} @section Attribute Simple_Storage_Pool @@ -11633,7 +11621,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{19e} +@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{19d} @section Attribute Small @@ -11649,7 +11637,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{19f} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-denominator}@anchor{19e} @section Attribute Small_Denominator @@ -11662,7 +11650,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{1a0} +@anchor{gnat_rm/implementation_defined_attributes attribute-small-numerator}@anchor{19f} @section Attribute Small_Numerator @@ -11675,7 +11663,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{1a1} +@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{1a0} @section Attribute Storage_Unit @@ -11685,7 +11673,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{1a2} +@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{1a1} @section Attribute Stub_Type @@ -11709,7 +11697,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{1a3} +@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{1a2} @section Attribute System_Allocator_Alignment @@ -11726,7 +11714,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{1a4} +@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{1a3} @section Attribute Target_Name @@ -11739,7 +11727,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{1a5} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{1a4} @section Attribute To_Address @@ -11762,7 +11750,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{1a6} +@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{1a5} @section Attribute To_Any @@ -11772,7 +11760,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{1a7} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{1a6} @section Attribute Type_Class @@ -11802,7 +11790,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{1a8} +@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{1a7} @section Attribute Type_Key @@ -11814,7 +11802,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{1a9} +@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{1a8} @section Attribute TypeCode @@ -11824,7 +11812,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{1aa} +@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{1a9} @section Attribute Unconstrained_Array @@ -11838,7 +11826,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{1ab} +@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{1aa} @section Attribute Universal_Literal_String @@ -11866,7 +11854,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{1ac} +@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{1ab} @section Attribute Unrestricted_Access @@ -12053,7 +12041,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_Image,Attribute Unrestricted_Access,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ad} +@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1ac} @section Attribute Update @@ -12134,7 +12122,7 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30); which changes element (1,2) to 20 and (3,4) to 30. @node Attribute Valid_Image,Attribute Valid_Scalars,Attribute Update,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-image}@anchor{1ae} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-image}@anchor{1ad} @section Attribute Valid_Image @@ -12146,7 +12134,7 @@ a String, and returns Boolean. @code{T'Valid_Image (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_Image,Implementation Defined Attributes -@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1af} +@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1ae} @section Attribute Valid_Scalars @@ -12180,7 +12168,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{1b0} +@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1af} @section Attribute VADS_Size @@ -12200,7 +12188,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{15d}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b1} +@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{15d}@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1b0} @section Attribute Value_Size @@ -12214,7 +12202,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{1b2} +@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1b1} @section Attribute Wchar_T_Size @@ -12226,7 +12214,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{1b3} +@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1b2} @section Attribute Word_Size @@ -12237,7 +12225,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{1b4}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b5}@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{1b3}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1b4}@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9} @chapter Standard and Implementation Defined Restrictions @@ -12266,7 +12254,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{1b6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1b5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1b6} @section Partition-Wide Restrictions @@ -12357,7 +12345,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{1b8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1b7} @subsection Immediate_Reclamation @@ -12369,7 +12357,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{1b9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1b8} @subsection Max_Asynchronous_Select_Nesting @@ -12381,7 +12369,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{1ba} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1b9} @subsection Max_Entry_Queue_Length @@ -12402,7 +12390,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{1bb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1ba} @subsection Max_Protected_Entries @@ -12413,7 +12401,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{1bc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1bb} @subsection Max_Select_Alternatives @@ -12422,7 +12410,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{1bd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1bc} @subsection Max_Storage_At_Blocking @@ -12433,7 +12421,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{1be} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1bd} @subsection Max_Task_Entries @@ -12446,7 +12434,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{1bf} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1be} @subsection Max_Tasks @@ -12459,7 +12447,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{1c0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1bf} @subsection No_Abort_Statements @@ -12469,7 +12457,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{1c1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1c0} @subsection No_Access_Parameter_Allocators @@ -12480,7 +12468,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{1c2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1c1} @subsection No_Access_Subprograms @@ -12490,7 +12478,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{1c3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1c2} @subsection No_Allocators @@ -12500,7 +12488,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{1c4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1c3} @subsection No_Anonymous_Allocators @@ -12510,7 +12498,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{1c5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1c4} @subsection No_Asynchronous_Control @@ -12520,7 +12508,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{1c6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1c5} @subsection No_Calendar @@ -12530,7 +12518,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{1c7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1c6} @subsection No_Coextensions @@ -12540,7 +12528,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{1c8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1c7} @subsection No_Default_Initialization @@ -12557,7 +12545,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{1c9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1c8} @subsection No_Delay @@ -12567,7 +12555,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{1ca} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1c9} @subsection No_Dependence @@ -12579,7 +12567,7 @@ dependences on units of the runtime library that are created by the compiler to support specific constructs of the language. @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{1cb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1ca} @subsection No_Direct_Boolean_Operators @@ -12592,7 +12580,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{1cc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1cb} @subsection No_Dispatch @@ -12602,7 +12590,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{1cd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1cc} @subsection No_Dispatching_Calls @@ -12663,7 +12651,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{1ce} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1cd} @subsection No_Dynamic_Attachment @@ -12682,7 +12670,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{1cf} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1ce} @subsection No_Dynamic_Priorities @@ -12691,7 +12679,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{1d0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1cf} @subsection No_Entry_Calls_In_Elaboration_Code @@ -12703,7 +12691,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{1d1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1d0} @subsection No_Enumeration_Maps @@ -12714,7 +12702,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{1d2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1d1} @subsection No_Exception_Handlers @@ -12739,7 +12727,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{1d3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1d2} @subsection No_Exception_Propagation @@ -12756,7 +12744,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{1d4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1d3} @subsection No_Exception_Registration @@ -12770,7 +12758,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{1d5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1d4} @subsection No_Exceptions @@ -12781,7 +12769,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{1d6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1d5} @subsection No_Finalization @@ -12822,7 +12810,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{1d7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1d6} @subsection No_Fixed_Point @@ -12832,7 +12820,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{1d8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1d7} @subsection No_Floating_Point @@ -12842,7 +12830,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{1d9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1d8} @subsection No_Implicit_Conditionals @@ -12858,7 +12846,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{1da} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1d9} @subsection No_Implicit_Dynamic_Code @@ -12888,7 +12876,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{1db} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1da} @subsection No_Implicit_Heap_Allocations @@ -12897,7 +12885,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{1dc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1db} @subsection No_Implicit_Protected_Object_Allocations @@ -12907,7 +12895,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{1dd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1dc} @subsection No_Implicit_Task_Allocations @@ -12916,7 +12904,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{1de} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1dd} @subsection No_Initialize_Scalars @@ -12928,7 +12916,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{1df} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1de} @subsection No_IO @@ -12939,7 +12927,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{1e0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1df} @subsection No_Local_Allocators @@ -12950,7 +12938,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{1e1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1e0} @subsection No_Local_Protected_Objects @@ -12960,7 +12948,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{1e2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-tagged-types}@anchor{1e1} @subsection No_Local_Tagged_Types @@ -12970,7 +12958,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{1e3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1e2} @subsection No_Local_Timing_Events @@ -12980,7 +12968,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{1e4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1e3} @subsection No_Long_Long_Integers @@ -12992,7 +12980,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{1e5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1e4} @subsection No_Multiple_Elaboration @@ -13008,7 +12996,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{1e6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1e5} @subsection No_Nested_Finalization @@ -13017,7 +13005,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{1e7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1e6} @subsection No_Protected_Type_Allocators @@ -13027,7 +13015,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{1e8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1e7} @subsection No_Protected_Types @@ -13037,7 +13025,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{1e9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1e8} @subsection No_Recursion @@ -13047,7 +13035,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{1ea} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1e9} @subsection No_Reentrancy @@ -13057,7 +13045,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{1eb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1ea} @subsection No_Relative_Delay @@ -13068,7 +13056,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{1ec} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1eb} @subsection No_Requeue_Statements @@ -13086,7 +13074,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{1ed} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1ec} @subsection No_Secondary_Stack @@ -13099,7 +13087,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{1ee} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1ed} @subsection No_Select_Statements @@ -13109,7 +13097,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{1ef} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1ee} @subsection No_Specific_Termination_Handlers @@ -13119,7 +13107,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{1f0} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1ef} @subsection No_Specification_of_Aspect @@ -13130,7 +13118,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{1f1} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1f0} @subsection No_Standard_Allocators_After_Elaboration @@ -13142,7 +13130,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{1f2} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1f1} @subsection No_Standard_Storage_Pools @@ -13154,7 +13142,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{1f3} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1f2} @subsection No_Stream_Optimizations @@ -13167,7 +13155,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{1f4} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1f3} @subsection No_Streams @@ -13188,7 +13176,7 @@ unit declaring a tagged type should be compiled with the restriction, though this is not required. @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{1f5} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tagged-type-registration}@anchor{1f4} @subsection No_Tagged_Type_Registration @@ -13203,7 +13191,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{1f6} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1f5} @subsection No_Task_Allocators @@ -13213,7 +13201,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{1f7} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1f6} @subsection No_Task_At_Interrupt_Priority @@ -13225,7 +13213,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{1f8} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1f7} @subsection No_Task_Attributes_Package @@ -13242,7 +13230,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{1f9} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1f8} @subsection No_Task_Hierarchy @@ -13252,7 +13240,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{1fa} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1f9} @subsection No_Task_Termination @@ -13261,7 +13249,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{1fb} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1fa} @subsection No_Tasking @@ -13274,7 +13262,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{1fc} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1fb} @subsection No_Terminate_Alternatives @@ -13283,7 +13271,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{1fd} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1fc} @subsection No_Unchecked_Access @@ -13293,7 +13281,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{1fe} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1fd} @subsection No_Unchecked_Conversion @@ -13303,7 +13291,7 @@ occurrences of the Unchecked_Access attribute. dependences on the predefined generic function Unchecked_Conversion. @node No_Unchecked_Deallocation,No_Use_Of_Entity,No_Unchecked_Conversion,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1ff} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1fe} @subsection No_Unchecked_Deallocation @@ -13313,7 +13301,7 @@ dependences on the predefined generic function Unchecked_Conversion. dependences on the predefined generic procedure Unchecked_Deallocation. @node No_Use_Of_Entity,Pure_Barriers,No_Unchecked_Deallocation,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{200} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1ff} @subsection No_Use_Of_Entity @@ -13333,7 +13321,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line @end example @node Pure_Barriers,Simple_Barriers,No_Use_Of_Entity,Partition-Wide Restrictions -@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{201} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{200} @subsection Pure_Barriers @@ -13384,7 +13372,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{202} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{201} @subsection Simple_Barriers @@ -13403,7 +13391,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{203} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{202} @subsection Static_Priorities @@ -13414,7 +13402,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{204} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{203} @subsection Static_Storage_Size @@ -13424,7 +13412,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{205}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{206} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{204}@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{205} @section Program Unit Level Restrictions @@ -13455,7 +13443,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{207} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{206} @subsection No_Elaboration_Code @@ -13511,7 +13499,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{208} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-accessibility-checks}@anchor{207} @subsection No_Dynamic_Accessibility_Checks @@ -13560,7 +13548,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{209} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{208} @subsection No_Dynamic_Sized_Objects @@ -13578,7 +13566,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{20a} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{209} @subsection No_Entry_Queue @@ -13591,7 +13579,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{20b} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{20a} @subsection No_Implementation_Aspect_Specifications @@ -13602,7 +13590,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{20c} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{20b} @subsection No_Implementation_Attributes @@ -13614,7 +13602,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{20d} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{20c} @subsection No_Implementation_Identifiers @@ -13625,7 +13613,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{20e} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{20d} @subsection No_Implementation_Pragmas @@ -13636,7 +13624,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{20f} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{20e} @subsection No_Implementation_Restrictions @@ -13648,7 +13636,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{210} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{20f} @subsection No_Implementation_Units @@ -13659,7 +13647,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{211} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{210} @subsection No_Implicit_Aliasing @@ -13674,7 +13662,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{212} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{211} @subsection No_Implicit_Loops @@ -13691,7 +13679,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{213} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{212} @subsection No_Obsolescent_Features @@ -13701,7 +13689,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{214} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{213} @subsection No_Wide_Characters @@ -13715,7 +13703,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{215} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-dispatch-tables}@anchor{214} @subsection Static_Dispatch_Tables @@ -13725,7 +13713,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{216} +@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{215} @subsection SPARK_05 @@ -13748,7 +13736,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{217}@anchor{gnat_rm/implementation_advice id1}@anchor{218}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} +@anchor{gnat_rm/implementation_advice doc}@anchor{216}@anchor{gnat_rm/implementation_advice id1}@anchor{217}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a} @chapter Implementation Advice @@ -13846,7 +13834,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{219} +@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{218} @section RM 1.1.3(20): Error Detection @@ -13863,7 +13851,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{21a} +@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{219} @section RM 1.1.3(31): Child Units @@ -13879,7 +13867,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{21b} +@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{21a} @section RM 1.1.5(12): Bounded Errors @@ -13896,7 +13884,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{21c}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21d} +@anchor{gnat_rm/implementation_advice id2}@anchor{21b}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{21c} @section RM 2.8(16): Pragmas @@ -14009,7 +13997,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{21e} +@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{21d} @section RM 2.8(17-19): Pragmas @@ -14030,14 +14018,14 @@ replacing @code{library_items}.” @end itemize @end quotation -See @ref{21d,,RM 2.8(16); Pragmas}. +See @ref{21c,,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{21f} +@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{21e} @section RM 3.5.2(5): Alternative Character Sets @@ -14065,7 +14053,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{220} +@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{21f} @section RM 3.5.4(28): Integer Types @@ -14084,7 +14072,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{221} +@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{220} @section RM 3.5.4(29): Integer Types @@ -14100,7 +14088,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{222} +@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{221} @section RM 3.5.5(8): Enumeration Values @@ -14120,7 +14108,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{223} +@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{222} @section RM 3.5.7(17): Float Types @@ -14150,7 +14138,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{224} +@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{223} @section RM 3.6.2(11): Multidimensional Arrays @@ -14168,7 +14156,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{225} +@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{224} @section RM 9.6(30-31): Duration’Small @@ -14189,7 +14177,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{226} +@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{225} @section RM 10.2.1(12): Consistent Representation @@ -14211,7 +14199,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{227} +@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{226} @section RM 11.4.1(19): Exception Information @@ -14242,7 +14230,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{228} +@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{227} @section RM 11.5(28): Suppression of Checks @@ -14257,7 +14245,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{229} +@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{228} @section RM 13.1 (21-24): Representation Clauses @@ -14306,7 +14294,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{22a} +@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{229} @section RM 13.2(6-8): Packed Types @@ -14337,7 +14325,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{22b} +@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{22a} @section RM 13.3(14-19): Address Clauses @@ -14390,7 +14378,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{22c} +@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{22b} @section RM 13.3(29-35): Alignment Clauses @@ -14447,7 +14435,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{22d} +@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{22c} @section RM 13.3(42-43): Size Clauses @@ -14465,7 +14453,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{22e} +@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{22d} @section RM 13.3(50-56): Size Clauses @@ -14516,7 +14504,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{22f} +@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{22e} @section RM 13.3(71-73): Component Size Clauses @@ -14550,7 +14538,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{230} +@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{22f} @section RM 13.4(9-10): Enumeration Representation Clauses @@ -14572,7 +14560,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{231} +@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{230} @section RM 13.5.1(17-22): Record Representation Clauses @@ -14632,7 +14620,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{232} +@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{231} @section RM 13.5.2(5): Storage Place Attributes @@ -14652,7 +14640,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{233} +@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{232} @section RM 13.5.3(7-8): Bit Ordering @@ -14672,7 +14660,7 @@ Thus non-default bit ordering is not supported. @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{234} +@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{233} @section RM 13.7(37): Address as Private @@ -14690,7 +14678,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{235} +@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{234} @section RM 13.7.1(16): Address Operations @@ -14708,7 +14696,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{236} +@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{235} @section RM 13.9(14-17): Unchecked Conversion @@ -14752,7 +14740,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{237} +@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{236} @section RM 13.11(23-25): Implicit Heap Usage @@ -14803,7 +14791,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{238} +@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{237} @section RM 13.11.2(17): Unchecked Deallocation @@ -14818,7 +14806,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{239} +@anchor{gnat_rm/implementation_advice rm-13-13-2-1-6-stream-oriented-attributes}@anchor{238} @section RM 13.13.2(1.6): Stream Oriented Attributes @@ -14849,7 +14837,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{23a} +@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{239} @section RM A.1(52): Names of Predefined Numeric Types @@ -14867,7 +14855,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{23b} +@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{23a} @section RM A.3.2(49): @code{Ada.Characters.Handling} @@ -14884,7 +14872,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{23c} +@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{23b} @section RM A.4.4(106): Bounded-Length String Handling @@ -14899,7 +14887,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{23d} +@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{23c} @section RM A.5.2(46-47): Random Number Generation @@ -14928,7 +14916,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{23e} +@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{23d} @section RM A.10.7(23): @code{Get_Immediate} @@ -14952,7 +14940,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{23f} +@anchor{gnat_rm/implementation_advice rm-a-18-containers}@anchor{23e} @section RM A.18: @code{Containers} @@ -14973,7 +14961,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{240} +@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{23f} @section RM B.1(39-41): Pragma @code{Export} @@ -15021,7 +15009,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{241} +@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{240} @section RM B.2(12-13): Package @code{Interfaces} @@ -15051,7 +15039,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{242} +@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{241} @section RM B.3(63-71): Interfacing with C @@ -15139,7 +15127,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{243} +@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{242} @section RM B.4(95-98): Interfacing with COBOL @@ -15180,7 +15168,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{244} +@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{243} @section RM B.5(22-26): Interfacing with Fortran @@ -15231,7 +15219,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{245} +@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{244} @section RM C.1(3-5): Access to Machine Operations @@ -15266,7 +15254,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{246} +@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{245} @section RM C.1(10-16): Access to Machine Operations @@ -15327,7 +15315,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{247} +@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{246} @section RM C.3(28): Interrupt Support @@ -15345,7 +15333,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{248} +@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{247} @section RM C.3.1(20-21): Protected Procedure Handlers @@ -15371,7 +15359,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{249} +@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{248} @section RM C.3.2(25): Package @code{Interrupts} @@ -15389,7 +15377,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{24a} +@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{249} @section RM C.4(14): Pre-elaboration Requirements @@ -15405,7 +15393,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{24b} +@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{24a} @section RM C.5(8): Pragma @code{Discard_Names} @@ -15423,7 +15411,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{24c} +@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{24b} @section RM C.7.2(30): The Package Task_Attributes @@ -15444,7 +15432,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{24d} +@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{24c} @section RM D.3(17): Locking Policies @@ -15461,7 +15449,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{24e} +@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{24d} @section RM D.4(16): Entry Queuing Policies @@ -15476,7 +15464,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{24f} +@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{24e} @section RM D.6(9-10): Preemptive Abort @@ -15502,7 +15490,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{250} +@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{24f} @section RM D.7(21): Tasking Restrictions @@ -15521,7 +15509,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{251} +@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{250} @section RM D.8(47-49): Monotonic Time @@ -15556,7 +15544,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{252} +@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{251} @section RM E.5(28-29): Partition Communication Subsystem @@ -15584,7 +15572,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{253} +@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{252} @section RM F(7): COBOL Support @@ -15604,7 +15592,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{254} +@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{253} @section RM F.1(2): Decimal Radix Support @@ -15620,7 +15608,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{255} +@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{254} @section RM G: Numerics @@ -15640,7 +15628,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{256} +@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{255} @section RM G.1.1(56-58): Complex Types @@ -15702,7 +15690,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{257} +@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{256} @section RM G.1.2(49): Complex Elementary Functions @@ -15724,7 +15712,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{258} +@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{257} @section RM G.2.4(19): Accuracy Requirements @@ -15748,7 +15736,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{259} +@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{258} @section RM G.2.6(15): Complex Arithmetic Accuracy @@ -15766,7 +15754,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{25a} +@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{259} @section RM H.6(15/2): Pragma Partition_Elaboration_Policy @@ -15781,7 +15769,7 @@ immediately terminated.” Not followed. @node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top -@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{25b}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{25c}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b} +@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{25a}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{25b}@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b} @chapter Implementation Defined Characteristics @@ -17076,7 +17064,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{25d,,GNAT.Regexp (g-regexp.ads)}. +See @ref{25c,,GNAT.Regexp (g-regexp.ads)}. @itemize * @@ -18166,7 +18154,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{25e}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} +@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{25e}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c} @chapter Intrinsic Subprograms @@ -18204,7 +18192,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{260}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{261} +@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{260} @section Intrinsic Operators @@ -18235,7 +18223,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{262}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{263} +@anchor{gnat_rm/intrinsic_subprograms compilation-iso-date}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{262} @section Compilation_ISO_Date @@ -18249,7 +18237,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{264}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{265} +@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{263}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{264} @section Compilation_Date @@ -18259,7 +18247,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{266}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{267} +@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{265}@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{266} @section Compilation_Time @@ -18273,7 +18261,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{268}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{269} +@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{267}@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{268} @section Enclosing_Entity @@ -18287,7 +18275,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{26a}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{26b} +@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{269}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{26a} @section Exception_Information @@ -18301,7 +18289,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{26c}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26d} +@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{26b}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{26c} @section Exception_Message @@ -18315,7 +18303,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{26e}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26f} +@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{26d}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{26e} @section Exception_Name @@ -18329,7 +18317,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{270}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{271} +@anchor{gnat_rm/intrinsic_subprograms file}@anchor{26f}@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{270} @section File @@ -18343,7 +18331,7 @@ application program should simply call the function file. @node Line,Shifts and Rotates,File,Intrinsic Subprograms -@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{272}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{273} +@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{271}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{272} @section Line @@ -18357,7 +18345,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{274}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{275} +@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{273}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{274} @section Shifts and Rotates @@ -18400,7 +18388,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{276}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{277} +@anchor{gnat_rm/intrinsic_subprograms id13}@anchor{275}@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{276} @section Source_Location @@ -18414,7 +18402,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{278}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} +@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{277}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{278}@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d} @chapter Representation Clauses and Pragmas @@ -18460,7 +18448,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{27a}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{27b} +@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{27a} @section Alignment Clauses @@ -18482,7 +18470,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{18d,,Attribute Maximum_Alignment}.) +@code{Standard'Maximum_Alignment}; see @ref{18c,,Attribute Maximum_Alignment}.) @geindex Maximum_Alignment attribute @@ -18591,7 +18579,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{27c}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27d} +@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{27c} @section Size Clauses @@ -18668,7 +18656,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{27e}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27f} +@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{27e} @section Storage_Size Clauses @@ -18741,7 +18729,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{280}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{281} +@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{280} @section Size of Variant Record Objects @@ -18851,7 +18839,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{282}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{283} +@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{282} @section Biased Representation @@ -18889,7 +18877,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{284}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{285} +@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{284} @section Value_Size and Object_Size Clauses @@ -19205,7 +19193,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{286}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{287} +@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{286} @section Component_Size Clauses @@ -19253,7 +19241,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{288}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{289} +@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{287}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{288} @section Bit_Order Clauses @@ -19359,7 +19347,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{28a}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{28b} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{28a} @section Effect of Bit_Order on Byte Ordering @@ -19616,7 +19604,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{28c}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28d} +@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{28b}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{28c} @section Pragma Pack for Arrays @@ -19736,7 +19724,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{28e}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28f} +@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{28d}@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{28e} @section Pragma Pack for Records @@ -19820,7 +19808,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{290}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{291} +@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{28f}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{290} @section Record Representation Clauses @@ -19899,7 +19887,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{292}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{293} +@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{291}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{292} @section Handling of Records with Holes @@ -19975,7 +19963,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{294}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{295} +@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{293}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{294} @section Enumeration Clauses @@ -20018,7 +20006,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{296}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{297} +@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{295}@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{296} @section Address Clauses @@ -20358,7 +20346,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{298}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{299} +@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{297}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{298} @section Use of Address Clauses for Memory-Mapped I/O @@ -20416,7 +20404,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{29a}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{29b} +@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{299}@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{29a} @section Effect of Convention on Representation @@ -20494,7 +20482,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{29c}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29d} +@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{29b}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{29c} @section Conventions and Anonymous Access Types @@ -20570,7 +20558,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{29e}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29f} +@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{29d}@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{29e} @section Determining the Representations chosen by GNAT @@ -20722,7 +20710,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{2a0}@anchor{gnat_rm/standard_library_routines id1}@anchor{2a1}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} +@anchor{gnat_rm/standard_library_routines doc}@anchor{29f}@anchor{gnat_rm/standard_library_routines id1}@anchor{2a0}@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e} @chapter Standard Library Routines @@ -21546,7 +21534,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{2a2}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a3}@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{2a1}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{2a2}@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f} @chapter The Implementation of Standard I/O @@ -21598,7 +21586,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{2a4}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a5} +@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{2a4} @section Standard I/O Packages @@ -21669,7 +21657,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{2a6}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a7} +@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{2a6} @section FORM Strings @@ -21695,7 +21683,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{2a8}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a9} +@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{2a8} @section Direct_IO @@ -21715,7 +21703,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{2aa}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2ab} +@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{2aa} @section Sequential_IO @@ -21762,7 +21750,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{2ac}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2ad} +@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{2ac} @section Text_IO @@ -21845,7 +21833,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{2ae}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2af} +@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{2ae} @subsection Stream Pointer Positioning @@ -21881,7 +21869,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{2b0}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2b1} +@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{2b0} @subsection Reading and Writing Non-Regular Files @@ -21932,7 +21920,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{2b2}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b3} +@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{2b2} @subsection Get_Immediate @@ -21950,7 +21938,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{2b4}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b5} +@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2b4} @subsection Treating Text_IO Files as Streams @@ -21966,7 +21954,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{2b6}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b7} +@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2b6} @subsection Text_IO Extensions @@ -21994,7 +21982,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{2b8}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b9} +@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2b8} @subsection Text_IO Facilities for Unbounded Strings @@ -22042,7 +22030,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{2ba}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2bb} +@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2ba} @section Wide_Text_IO @@ -22289,12 +22277,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{2bc}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2bd} +@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2bc} @subsection Stream Pointer Positioning @code{Ada.Wide_Text_IO} is similar to @code{Ada.Text_IO} in its handling -of stream pointer positioning (@ref{2ad,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2ac,,Text_IO}). There is one additional case: If @code{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22313,7 +22301,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{2be}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2bf} +@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2be} @subsection Reading and Writing Non-Regular Files @@ -22324,7 +22312,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{2c0}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2c1} +@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2c0} @section Wide_Wide_Text_IO @@ -22493,12 +22481,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{2c2}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c3} +@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2c1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2c2} @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{2ad,,Text_IO}). There is one additional +of stream pointer positioning (@ref{2ac,,Text_IO}). There is one additional case: If @code{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the @@ -22517,7 +22505,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{2c4}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c5} +@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2c3}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2c4} @subsection Reading and Writing Non-Regular Files @@ -22528,7 +22516,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{2c6}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c7} +@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2c5}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2c6} @section Stream_IO @@ -22550,7 +22538,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{2c8}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c9} +@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2c7}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2c8} @section Text Translation @@ -22584,7 +22572,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{2ca}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2cb} +@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2c9}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2ca} @section Shared Files @@ -22647,7 +22635,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{2cc}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2cd} +@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2cb}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2cc} @section Filenames encoding @@ -22687,7 +22675,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{2ce}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2cf} +@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2cd}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ce} @section File content encoding @@ -22720,7 +22708,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{2d0}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2d1} +@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2cf}@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2d0} @section Open Modes @@ -22823,7 +22811,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{2d2}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d3} +@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2d1}@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2d2} @section Operations on C Streams @@ -22983,7 +22971,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{2d4}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d5} +@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2d3}@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2d4} @section Interfacing to C Streams @@ -23076,7 +23064,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{2d6}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d7}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} +@anchor{gnat_rm/the_gnat_library doc}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id1}@anchor{2d6}@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10} @chapter The GNAT Library @@ -23115,17 +23103,6 @@ of GNAT, and will generate a warning message. * Ada.Characters.Wide_Latin_9 (a-cwila1.ads): Ada Characters Wide_Latin_9 a-cwila1 ads. * Ada.Characters.Wide_Wide_Latin_1 (a-chzla1.ads): Ada Characters Wide_Wide_Latin_1 a-chzla1 ads. * Ada.Characters.Wide_Wide_Latin_9 (a-chzla9.ads): Ada Characters Wide_Wide_Latin_9 a-chzla9 ads. -* Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads): Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads. -* Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads): Ada Containers Formal_Hashed_Maps a-cfhama ads. -* Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads): Ada Containers Formal_Hashed_Sets a-cfhase ads. -* Ada.Containers.Formal_Ordered_Maps (a-cforma.ads): Ada Containers Formal_Ordered_Maps a-cforma ads. -* Ada.Containers.Formal_Ordered_Sets (a-cforse.ads): Ada Containers Formal_Ordered_Sets a-cforse ads. -* Ada.Containers.Formal_Vectors (a-cofove.ads): Ada Containers Formal_Vectors a-cofove ads. -* Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads): Ada Containers Formal_Indefinite_Vectors a-cfinve ads. -* Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads): Ada Containers Functional_Infinite_Sequences a-cfinse ads. -* Ada.Containers.Functional_Vectors (a-cofuve.ads): Ada Containers Functional_Vectors a-cofuve ads. -* Ada.Containers.Functional_Sets (a-cofuse.ads): Ada Containers Functional_Sets a-cofuse ads. -* Ada.Containers.Functional_Maps (a-cofuma.ads): Ada Containers Functional_Maps a-cofuma ads. * Ada.Containers.Bounded_Holders (a-coboho.ads): Ada Containers Bounded_Holders a-coboho ads. * Ada.Command_Line.Environment (a-colien.ads): Ada Command_Line Environment a-colien ads. * Ada.Command_Line.Remove (a-colire.ads): Ada Command_Line Remove a-colire ads. @@ -23273,7 +23250,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{2d8}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d9} +@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2d7}@anchor{gnat_rm/the_gnat_library id2}@anchor{2d8} @section @code{Ada.Characters.Latin_9} (@code{a-chlat9.ads}) @@ -23290,7 +23267,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-cwila1 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{2da}@anchor{gnat_rm/the_gnat_library id3}@anchor{2db} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id3}@anchor{2da} @section @code{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads}) @@ -23307,7 +23284,7 @@ is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). @node Ada Characters Wide_Latin_9 a-cwila1 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-cwila1-ads}@anchor{2dc}@anchor{gnat_rm/the_gnat_library id4}@anchor{2dd} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id4}@anchor{2dc} @section @code{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads}) @@ -23324,7 +23301,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-cwila1 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2de}@anchor{gnat_rm/the_gnat_library id5}@anchor{2df} +@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id5}@anchor{2de} @section @code{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads}) @@ -23340,8 +23317,8 @@ instead of @code{Character}. The provision of such a package 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 Formal_Doubly_Linked_Lists a-cfdlli 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{2e0}@anchor{gnat_rm/the_gnat_library id6}@anchor{2e1} +@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{2df}@anchor{gnat_rm/the_gnat_library id6}@anchor{2e0} @section @code{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads}) @@ -23357,227 +23334,8 @@ instead of @code{Character}. The provision of such a package is specifically authorized by the Ada Reference Manual (RM A.3.3(27)). -@node Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2e2}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e3} -@section @code{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads}) - - -@geindex Ada.Containers.Formal_Doubly_Linked_Lists (a-cfdlli.ads) - -@geindex Formal container for doubly linked lists - -This child of @code{Ada.Containers} defines a modified version of the -Ada 2005 container for doubly linked lists, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -@node Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2e4}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e5} -@section @code{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads}) - - -@geindex Ada.Containers.Formal_Hashed_Maps (a-cfhama.ads) - -@geindex Formal container for hashed maps - -This child of @code{Ada.Containers} defines a modified version of the -Ada 2005 container for hashed maps, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -@node Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2e6}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e7} -@section @code{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads}) - - -@geindex Ada.Containers.Formal_Hashed_Sets (a-cfhase.ads) - -@geindex Formal container for hashed sets - -This child of @code{Ada.Containers} defines a modified version of the -Ada 2005 container for hashed sets, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -@node Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2e8}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e9} -@section @code{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads}) - - -@geindex Ada.Containers.Formal_Ordered_Maps (a-cforma.ads) - -@geindex Formal container for ordered maps - -This child of @code{Ada.Containers} defines a modified version of the -Ada 2005 container for ordered maps, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -@node Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Ordered_Maps a-cforma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2ea}@anchor{gnat_rm/the_gnat_library id11}@anchor{2eb} -@section @code{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads}) - - -@geindex Ada.Containers.Formal_Ordered_Sets (a-cforse.ads) - -@geindex Formal container for ordered sets - -This child of @code{Ada.Containers} defines a modified version of the -Ada 2005 container for ordered sets, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -@node Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Formal_Ordered_Sets a-cforse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2ec}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ed} -@section @code{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads}) - - -@geindex Ada.Containers.Formal_Vectors (a-cofove.ads) - -@geindex Formal container for vectors - -This child of @code{Ada.Containers} defines a modified version of the -Ada 2005 container for vectors, meant to facilitate formal -verification of code using such containers. The specification of this -unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -@node Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Functional_Infinite_Sequences a-cfinse ads,Ada Containers Formal_Vectors a-cofove ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2ee}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ef} -@section @code{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads}) - - -@geindex Ada.Containers.Formal_Indefinite_Vectors (a-cfinve.ads) - -@geindex Formal container for vectors - -This child of @code{Ada.Containers} defines a modified version of the -Ada 2005 container for vectors of indefinite elements, meant to -facilitate formal verification of code using such containers. The -specification of this unit is compatible with SPARK 2014. - -Note that although this container was designed with formal verification -in mind, it may well be generally useful in that it is a simplified more -efficient version than the one defined in the standard. In particular it -does not have the complex overhead required to detect cursor tampering. - -@node Ada Containers Functional_Infinite_Sequences a-cfinse ads,Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-functional-infinite-sequences-a-cfinse-ads}@anchor{2f0}@anchor{gnat_rm/the_gnat_library id14}@anchor{2f1} -@section @code{Ada.Containers.Functional_Infinite_Sequences} (@code{a-cfinse.ads}) - - -@geindex Ada.Containers.Functional_Infinite_Sequences (a-cfinse.ads) - -@geindex Functional Infinite Sequences - -This child of @code{Ada.Containers} defines immutable sequences indexed by -@code{Big_Integer}. These containers are unbounded and may contain indefinite -elements. Their API features functions creating new containers from existing -ones. To remain reasonably efficient, their implementation involves sharing -between data-structures. As they are functional, that is, no primitives are -provided which would allow modifying an existing container, these containers -can still be used safely. - -These containers are controlled so that the allocated memory can be reclaimed -when the container is no longer referenced. Thus, they cannot directly be used -in contexts where controlled types are not supported. -The specification of this unit is compatible with SPARK 2014. - -@node Ada Containers Functional_Vectors a-cofuve ads,Ada Containers Functional_Sets a-cofuse ads,Ada Containers Functional_Infinite_Sequences a-cfinse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-functional-vectors-a-cofuve-ads}@anchor{2f2}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f3} -@section @code{Ada.Containers.Functional_Vectors} (@code{a-cofuve.ads}) - - -@geindex Ada.Containers.Functional_Vectors (a-cofuve.ads) - -@geindex Functional vectors - -This child of @code{Ada.Containers} defines immutable vectors. These -containers are unbounded and may contain indefinite elements. Furthermore, to -be usable in every context, they are neither controlled nor limited. As they -are functional, that is, no primitives are provided which would allow modifying -an existing container, these containers can still be used safely. - -Their API features functions creating new containers from existing ones. -As a consequence, these containers are highly inefficient. They are also -memory consuming, as the allocated memory is not reclaimed when the container -is no longer referenced. Thus, they should in general be used in ghost code -and annotations, so that they can be removed from the final executable. The -specification of this unit is compatible with SPARK 2014. - -@node Ada Containers Functional_Sets a-cofuse ads,Ada Containers Functional_Maps a-cofuma ads,Ada Containers Functional_Vectors a-cofuve ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-functional-sets-a-cofuse-ads}@anchor{2f4}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f5} -@section @code{Ada.Containers.Functional_Sets} (@code{a-cofuse.ads}) - - -@geindex Ada.Containers.Functional_Sets (a-cofuse.ads) - -@geindex Functional sets - -This child of @code{Ada.Containers} defines immutable sets. These containers are -unbounded and may contain indefinite elements. Their API features functions -creating new containers from existing ones. To remain reasonably efficient, -their implementation involves sharing between data-structures. As they are -functional, that is, no primitives are provided which would allow modifying an -existing container, these containers can still be used safely. - -These containers are controlled so that the allocated memory can be reclaimed -when the container is no longer referenced. Thus, they cannot directly be used -in contexts where controlled types are not supported. -The specification of this unit is compatible with SPARK 2014. - -@node Ada Containers Functional_Maps a-cofuma ads,Ada Containers Bounded_Holders a-coboho ads,Ada Containers Functional_Sets a-cofuse ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-functional-maps-a-cofuma-ads}@anchor{2f6}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f7} -@section @code{Ada.Containers.Functional_Maps} (@code{a-cofuma.ads}) - - -@geindex Ada.Containers.Functional_Maps (a-cofuma.ads) - -@geindex Functional maps - -This child of @code{Ada.Containers} defines immutable maps. These containers are -unbounded and may contain indefinite elements. Their API features functions -creating new containers from existing ones. To remain reasonably efficient, -their implementation involves sharing between data-structures. As they are -functional, that is, no primitives are provided which would allow modifying an -existing container, these containers can still be used safely. - -These containers are controlled so that the allocated memory can be reclaimed -when the container is no longer referenced. Thus, they cannot directly be used -in contexts where controlled types are not supported. -The specification of this unit is compatible with SPARK 2014. - -@node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Containers Functional_Maps a-cofuma ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2f8}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f9} +@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{2e1}@anchor{gnat_rm/the_gnat_library id7}@anchor{2e2} @section @code{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads}) @@ -23589,7 +23347,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{2fa}@anchor{gnat_rm/the_gnat_library id19}@anchor{2fb} +@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2e3}@anchor{gnat_rm/the_gnat_library id8}@anchor{2e4} @section @code{Ada.Command_Line.Environment} (@code{a-colien.ads}) @@ -23602,7 +23360,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{2fc}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fd} +@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id9}@anchor{2e6} @section @code{Ada.Command_Line.Remove} (@code{a-colire.ads}) @@ -23620,7 +23378,7 @@ to further calls on the subprograms in @code{Ada.Command_Line} 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{2fe}@anchor{gnat_rm/the_gnat_library id21}@anchor{2ff} +@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id10}@anchor{2e8} @section @code{Ada.Command_Line.Response_File} (@code{a-clrefi.ads}) @@ -23640,7 +23398,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{300}@anchor{gnat_rm/the_gnat_library id22}@anchor{301} +@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2e9}@anchor{gnat_rm/the_gnat_library id11}@anchor{2ea} @section @code{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads}) @@ -23655,7 +23413,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{302}@anchor{gnat_rm/the_gnat_library id23}@anchor{303} +@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id12}@anchor{2ec} @section @code{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads}) @@ -23669,7 +23427,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{304}@anchor{gnat_rm/the_gnat_library id24}@anchor{305} +@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2ed}@anchor{gnat_rm/the_gnat_library id13}@anchor{2ee} @section @code{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads}) @@ -23683,7 +23441,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{306}@anchor{gnat_rm/the_gnat_library id25}@anchor{307} +@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id14}@anchor{2f0} @section @code{Ada.Exceptions.Traceback} (@code{a-exctra.ads}) @@ -23696,7 +23454,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{308}@anchor{gnat_rm/the_gnat_library id26}@anchor{309} +@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{2f1}@anchor{gnat_rm/the_gnat_library id15}@anchor{2f2} @section @code{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads}) @@ -23711,7 +23469,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{30a}@anchor{gnat_rm/the_gnat_library id27}@anchor{30b} +@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id16}@anchor{2f4} @section @code{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads}) @@ -23726,7 +23484,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{30c}@anchor{gnat_rm/the_gnat_library id28}@anchor{30d} +@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id17}@anchor{2f6} @section @code{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads}) @@ -23743,7 +23501,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{30e}@anchor{gnat_rm/the_gnat_library id29}@anchor{30f} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{2f7}@anchor{gnat_rm/the_gnat_library id18}@anchor{2f8} @section @code{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads}) @@ -23760,7 +23518,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{310}@anchor{gnat_rm/the_gnat_library id30}@anchor{311} +@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id19}@anchor{2fa} @section @code{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads}) @@ -23777,7 +23535,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{312}@anchor{gnat_rm/the_gnat_library id31}@anchor{313} +@anchor{gnat_rm/the_gnat_library ada-task-initialization-a-tasini-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id20}@anchor{2fc} @section @code{Ada.Task_Initialization} (@code{a-tasini.ads}) @@ -23789,7 +23547,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{314}@anchor{gnat_rm/the_gnat_library id32}@anchor{315} +@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id21}@anchor{2fe} @section @code{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads}) @@ -23804,7 +23562,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{316}@anchor{gnat_rm/the_gnat_library id33}@anchor{317} +@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id22}@anchor{300} @section @code{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads}) @@ -23819,7 +23577,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{318}@anchor{gnat_rm/the_gnat_library id34}@anchor{319} +@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id23}@anchor{302} @section @code{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads}) @@ -23832,7 +23590,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{31a}@anchor{gnat_rm/the_gnat_library id35}@anchor{31b} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id24}@anchor{304} @section @code{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads}) @@ -23847,7 +23605,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{31c}@anchor{gnat_rm/the_gnat_library id36}@anchor{31d} +@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id25}@anchor{306} @section @code{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads}) @@ -23862,7 +23620,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{31e}@anchor{gnat_rm/the_gnat_library id37}@anchor{31f} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{307}@anchor{gnat_rm/the_gnat_library id26}@anchor{308} @section @code{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads}) @@ -23875,7 +23633,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{320}@anchor{gnat_rm/the_gnat_library id38}@anchor{321} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{309}@anchor{gnat_rm/the_gnat_library id27}@anchor{30a} @section @code{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads}) @@ -23890,7 +23648,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{322}@anchor{gnat_rm/the_gnat_library id39}@anchor{323} +@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id28}@anchor{30c} @section @code{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads}) @@ -23905,7 +23663,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{324}@anchor{gnat_rm/the_gnat_library id40}@anchor{325} +@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id29}@anchor{30e} @section @code{GNAT.Altivec} (@code{g-altive.ads}) @@ -23918,7 +23676,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{326}@anchor{gnat_rm/the_gnat_library id41}@anchor{327} +@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id30}@anchor{310} @section @code{GNAT.Altivec.Conversions} (@code{g-altcon.ads}) @@ -23929,7 +23687,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{328}@anchor{gnat_rm/the_gnat_library id42}@anchor{329} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id31}@anchor{312} @section @code{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads}) @@ -23943,7 +23701,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{32a}@anchor{gnat_rm/the_gnat_library id43}@anchor{32b} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id32}@anchor{314} @section @code{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads}) @@ -23955,7 +23713,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{32c}@anchor{gnat_rm/the_gnat_library id44}@anchor{32d} +@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id33}@anchor{316} @section @code{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads}) @@ -23970,7 +23728,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{32e}@anchor{gnat_rm/the_gnat_library id45}@anchor{32f} +@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{317}@anchor{gnat_rm/the_gnat_library id34}@anchor{318} @section @code{GNAT.Array_Split} (@code{g-arrspl.ads}) @@ -23983,7 +23741,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{330}@anchor{gnat_rm/the_gnat_library id46}@anchor{331} +@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id35}@anchor{31a} @section @code{GNAT.AWK} (@code{g-awk.ads}) @@ -23998,7 +23756,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{332}@anchor{gnat_rm/the_gnat_library id47}@anchor{333} +@anchor{gnat_rm/the_gnat_library gnat-binary-search-g-binsea-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id36}@anchor{31c} @section @code{GNAT.Binary_Search} (@code{g-binsea.ads}) @@ -24010,7 +23768,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{334}@anchor{gnat_rm/the_gnat_library id48}@anchor{335} +@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{31d}@anchor{gnat_rm/the_gnat_library id37}@anchor{31e} @section @code{GNAT.Bind_Environment} (@code{g-binenv.ads}) @@ -24023,7 +23781,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{336}@anchor{gnat_rm/the_gnat_library id49}@anchor{337} +@anchor{gnat_rm/the_gnat_library gnat-branch-prediction-g-brapre-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id38}@anchor{320} @section @code{GNAT.Branch_Prediction} (@code{g-brapre.ads}) @@ -24034,7 +23792,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{338}@anchor{gnat_rm/the_gnat_library id50}@anchor{339} +@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id39}@anchor{322} @section @code{GNAT.Bounded_Buffers} (@code{g-boubuf.ads}) @@ -24049,7 +23807,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{33a}@anchor{gnat_rm/the_gnat_library id51}@anchor{33b} +@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{323}@anchor{gnat_rm/the_gnat_library id40}@anchor{324} @section @code{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads}) @@ -24062,7 +23820,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{33c}@anchor{gnat_rm/the_gnat_library id52}@anchor{33d} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id41}@anchor{326} @section @code{GNAT.Bubble_Sort} (@code{g-bubsor.ads}) @@ -24077,7 +23835,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{33e}@anchor{gnat_rm/the_gnat_library id53}@anchor{33f} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{327}@anchor{gnat_rm/the_gnat_library id42}@anchor{328} @section @code{GNAT.Bubble_Sort_A} (@code{g-busora.ads}) @@ -24093,7 +23851,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{340}@anchor{gnat_rm/the_gnat_library id54}@anchor{341} +@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id43}@anchor{32a} @section @code{GNAT.Bubble_Sort_G} (@code{g-busorg.ads}) @@ -24109,7 +23867,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{342}@anchor{gnat_rm/the_gnat_library id55}@anchor{343} +@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{32b}@anchor{gnat_rm/the_gnat_library id44}@anchor{32c} @section @code{GNAT.Byte_Order_Mark} (@code{g-byorma.ads}) @@ -24125,7 +23883,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{344}@anchor{gnat_rm/the_gnat_library id56}@anchor{345} +@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id45}@anchor{32e} @section @code{GNAT.Byte_Swapping} (@code{g-bytswa.ads}) @@ -24139,7 +23897,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{346}@anchor{gnat_rm/the_gnat_library id57}@anchor{347} +@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id46}@anchor{330} @section @code{GNAT.Calendar} (@code{g-calend.ads}) @@ -24153,7 +23911,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{348}@anchor{gnat_rm/the_gnat_library id58}@anchor{349} +@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{331}@anchor{gnat_rm/the_gnat_library id47}@anchor{332} @section @code{GNAT.Calendar.Time_IO} (@code{g-catiio.ads}) @@ -24164,7 +23922,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{34a}@anchor{gnat_rm/the_gnat_library id59}@anchor{34b} +@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id48}@anchor{334} @section @code{GNAT.CRC32} (@code{g-crc32.ads}) @@ -24181,7 +23939,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{34c}@anchor{gnat_rm/the_gnat_library id60}@anchor{34d} +@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id49}@anchor{336} @section @code{GNAT.Case_Util} (@code{g-casuti.ads}) @@ -24196,7 +23954,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{34e}@anchor{gnat_rm/the_gnat_library id61}@anchor{34f} +@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{337}@anchor{gnat_rm/the_gnat_library id50}@anchor{338} @section @code{GNAT.CGI} (@code{g-cgi.ads}) @@ -24211,7 +23969,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{350}@anchor{gnat_rm/the_gnat_library id62}@anchor{351} +@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id51}@anchor{33a} @section @code{GNAT.CGI.Cookie} (@code{g-cgicoo.ads}) @@ -24226,7 +23984,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{352}@anchor{gnat_rm/the_gnat_library id63}@anchor{353} +@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id52}@anchor{33c} @section @code{GNAT.CGI.Debug} (@code{g-cgideb.ads}) @@ -24238,7 +23996,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{354}@anchor{gnat_rm/the_gnat_library id64}@anchor{355} +@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id53}@anchor{33e} @section @code{GNAT.Command_Line} (@code{g-comlin.ads}) @@ -24251,7 +24009,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{356}@anchor{gnat_rm/the_gnat_library id65}@anchor{357} +@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id54}@anchor{340} @section @code{GNAT.Compiler_Version} (@code{g-comver.ads}) @@ -24269,7 +24027,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{358}@anchor{gnat_rm/the_gnat_library id66}@anchor{359} +@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{341}@anchor{gnat_rm/the_gnat_library id55}@anchor{342} @section @code{GNAT.Ctrl_C} (@code{g-ctrl_c.ads}) @@ -24280,7 +24038,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{35a}@anchor{gnat_rm/the_gnat_library id67}@anchor{35b} +@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{343}@anchor{gnat_rm/the_gnat_library id56}@anchor{344} @section @code{GNAT.Current_Exception} (@code{g-curexc.ads}) @@ -24297,7 +24055,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{35c}@anchor{gnat_rm/the_gnat_library id68}@anchor{35d} +@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{345}@anchor{gnat_rm/the_gnat_library id57}@anchor{346} @section @code{GNAT.Debug_Pools} (@code{g-debpoo.ads}) @@ -24314,7 +24072,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{35e}@anchor{gnat_rm/the_gnat_library id69}@anchor{35f} +@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id58}@anchor{348} @section @code{GNAT.Debug_Utilities} (@code{g-debuti.ads}) @@ -24327,7 +24085,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{360}@anchor{gnat_rm/the_gnat_library id70}@anchor{361} +@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{349}@anchor{gnat_rm/the_gnat_library id59}@anchor{34a} @section @code{GNAT.Decode_String} (@code{g-decstr.ads}) @@ -24351,7 +24109,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{362}@anchor{gnat_rm/the_gnat_library id71}@anchor{363} +@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id60}@anchor{34c} @section @code{GNAT.Decode_UTF8_String} (@code{g-deutst.ads}) @@ -24372,7 +24130,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{364}@anchor{gnat_rm/the_gnat_library id72}@anchor{365} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{34d}@anchor{gnat_rm/the_gnat_library id61}@anchor{34e} @section @code{GNAT.Directory_Operations} (@code{g-dirope.ads}) @@ -24385,7 +24143,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{366}@anchor{gnat_rm/the_gnat_library id73}@anchor{367} +@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{34f}@anchor{gnat_rm/the_gnat_library id62}@anchor{350} @section @code{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads}) @@ -24397,7 +24155,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{368}@anchor{gnat_rm/the_gnat_library id74}@anchor{369} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{351}@anchor{gnat_rm/the_gnat_library id63}@anchor{352} @section @code{GNAT.Dynamic_HTables} (@code{g-dynhta.ads}) @@ -24415,7 +24173,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{36a}@anchor{gnat_rm/the_gnat_library id75}@anchor{36b} +@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id64}@anchor{354} @section @code{GNAT.Dynamic_Tables} (@code{g-dyntab.ads}) @@ -24435,7 +24193,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{36c}@anchor{gnat_rm/the_gnat_library id76}@anchor{36d} +@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id65}@anchor{356} @section @code{GNAT.Encode_String} (@code{g-encstr.ads}) @@ -24457,7 +24215,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{36e}@anchor{gnat_rm/the_gnat_library id77}@anchor{36f} +@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{357}@anchor{gnat_rm/the_gnat_library id66}@anchor{358} @section @code{GNAT.Encode_UTF8_String} (@code{g-enutst.ads}) @@ -24478,7 +24236,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{370}@anchor{gnat_rm/the_gnat_library id78}@anchor{371} +@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id67}@anchor{35a} @section @code{GNAT.Exception_Actions} (@code{g-excact.ads}) @@ -24491,7 +24249,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{372}@anchor{gnat_rm/the_gnat_library id79}@anchor{373} +@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id68}@anchor{35c} @section @code{GNAT.Exception_Traces} (@code{g-exctra.ads}) @@ -24505,7 +24263,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{374}@anchor{gnat_rm/the_gnat_library id80}@anchor{375} +@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-except-ads}@anchor{35d}@anchor{gnat_rm/the_gnat_library id69}@anchor{35e} @section @code{GNAT.Exceptions} (@code{g-except.ads}) @@ -24526,7 +24284,7 @@ predefined exceptions, and for example allow 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{376}@anchor{gnat_rm/the_gnat_library id81}@anchor{377} +@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{35f}@anchor{gnat_rm/the_gnat_library id70}@anchor{360} @section @code{GNAT.Expect} (@code{g-expect.ads}) @@ -24542,7 +24300,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{378}@anchor{gnat_rm/the_gnat_library id82}@anchor{379} +@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{361}@anchor{gnat_rm/the_gnat_library id71}@anchor{362} @section @code{GNAT.Expect.TTY} (@code{g-exptty.ads}) @@ -24554,7 +24312,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{37a}@anchor{gnat_rm/the_gnat_library id83}@anchor{37b} +@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{363}@anchor{gnat_rm/the_gnat_library id72}@anchor{364} @section @code{GNAT.Float_Control} (@code{g-flocon.ads}) @@ -24568,7 +24326,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{37c}@anchor{gnat_rm/the_gnat_library id84}@anchor{37d} +@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{365}@anchor{gnat_rm/the_gnat_library id73}@anchor{366} @section @code{GNAT.Formatted_String} (@code{g-forstr.ads}) @@ -24583,7 +24341,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{37e}@anchor{gnat_rm/the_gnat_library id85}@anchor{37f} +@anchor{gnat_rm/the_gnat_library gnat-generic-fast-math-functions-g-gfmafu-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id74}@anchor{368} @section @code{GNAT.Generic_Fast_Math_Functions} (@code{g-gfmafu.ads}) @@ -24601,7 +24359,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{380}@anchor{gnat_rm/the_gnat_library id86}@anchor{381} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{369}@anchor{gnat_rm/the_gnat_library id75}@anchor{36a} @section @code{GNAT.Heap_Sort} (@code{g-heasor.ads}) @@ -24615,7 +24373,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{382}@anchor{gnat_rm/the_gnat_library id87}@anchor{383} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{36b}@anchor{gnat_rm/the_gnat_library id76}@anchor{36c} @section @code{GNAT.Heap_Sort_A} (@code{g-hesora.ads}) @@ -24631,7 +24389,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{384}@anchor{gnat_rm/the_gnat_library id88}@anchor{385} +@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{36d}@anchor{gnat_rm/the_gnat_library id77}@anchor{36e} @section @code{GNAT.Heap_Sort_G} (@code{g-hesorg.ads}) @@ -24645,7 +24403,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{386}@anchor{gnat_rm/the_gnat_library id89}@anchor{387} +@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{36f}@anchor{gnat_rm/the_gnat_library id78}@anchor{370} @section @code{GNAT.HTable} (@code{g-htable.ads}) @@ -24658,7 +24416,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{388}@anchor{gnat_rm/the_gnat_library id90}@anchor{389} +@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{371}@anchor{gnat_rm/the_gnat_library id79}@anchor{372} @section @code{GNAT.IO} (@code{g-io.ads}) @@ -24674,7 +24432,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{38a}@anchor{gnat_rm/the_gnat_library id91}@anchor{38b} +@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{373}@anchor{gnat_rm/the_gnat_library id80}@anchor{374} @section @code{GNAT.IO_Aux} (@code{g-io_aux.ads}) @@ -24688,7 +24446,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{38c}@anchor{gnat_rm/the_gnat_library id92}@anchor{38d} +@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id81}@anchor{376} @section @code{GNAT.Lock_Files} (@code{g-locfil.ads}) @@ -24702,7 +24460,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{38e}@anchor{gnat_rm/the_gnat_library id93}@anchor{38f} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id82}@anchor{378} @section @code{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads}) @@ -24714,7 +24472,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{390}@anchor{gnat_rm/the_gnat_library id94}@anchor{391} +@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{379}@anchor{gnat_rm/the_gnat_library id83}@anchor{37a} @section @code{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads}) @@ -24726,7 +24484,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{392}@anchor{gnat_rm/the_gnat_library id95}@anchor{393} +@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{37b}@anchor{gnat_rm/the_gnat_library id84}@anchor{37c} @section @code{GNAT.MD5} (@code{g-md5.ads}) @@ -24739,7 +24497,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{394}@anchor{gnat_rm/the_gnat_library id96}@anchor{395} +@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{37d}@anchor{gnat_rm/the_gnat_library id85}@anchor{37e} @section @code{GNAT.Memory_Dump} (@code{g-memdum.ads}) @@ -24752,7 +24510,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{396}@anchor{gnat_rm/the_gnat_library id97}@anchor{397} +@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{37f}@anchor{gnat_rm/the_gnat_library id86}@anchor{380} @section @code{GNAT.Most_Recent_Exception} (@code{g-moreex.ads}) @@ -24766,7 +24524,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{398}@anchor{gnat_rm/the_gnat_library id98}@anchor{399} +@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{381}@anchor{gnat_rm/the_gnat_library id87}@anchor{382} @section @code{GNAT.OS_Lib} (@code{g-os_lib.ads}) @@ -24782,7 +24540,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{39a}@anchor{gnat_rm/the_gnat_library id99}@anchor{39b} +@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{383}@anchor{gnat_rm/the_gnat_library id88}@anchor{384} @section @code{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads}) @@ -24800,7 +24558,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{39c}@anchor{gnat_rm/the_gnat_library id100}@anchor{39d} +@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{385}@anchor{gnat_rm/the_gnat_library id89}@anchor{386} @section @code{GNAT.Random_Numbers} (@code{g-rannum.ads}) @@ -24812,7 +24570,7 @@ Provides random number capabilities which extend those available in the standard Ada library and are more convenient to use. @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{25d}@anchor{gnat_rm/the_gnat_library id101}@anchor{39e} +@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{25c}@anchor{gnat_rm/the_gnat_library id90}@anchor{387} @section @code{GNAT.Regexp} (@code{g-regexp.ads}) @@ -24828,7 +24586,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{39f}@anchor{gnat_rm/the_gnat_library id102}@anchor{3a0} +@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{388}@anchor{gnat_rm/the_gnat_library id91}@anchor{389} @section @code{GNAT.Registry} (@code{g-regist.ads}) @@ -24842,7 +24600,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{3a1}@anchor{gnat_rm/the_gnat_library id103}@anchor{3a2} +@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{38a}@anchor{gnat_rm/the_gnat_library id92}@anchor{38b} @section @code{GNAT.Regpat} (@code{g-regpat.ads}) @@ -24857,7 +24615,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{3a3}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a4} +@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{38c}@anchor{gnat_rm/the_gnat_library id93}@anchor{38d} @section @code{GNAT.Rewrite_Data} (@code{g-rewdat.ads}) @@ -24871,7 +24629,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{3a5}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a6} +@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id94}@anchor{38f} @section @code{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads}) @@ -24883,7 +24641,7 @@ Provide 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{3a7}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a8} +@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id95}@anchor{391} @section @code{GNAT.Semaphores} (@code{g-semaph.ads}) @@ -24894,7 +24652,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{3a9}@anchor{gnat_rm/the_gnat_library id107}@anchor{3aa} +@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id96}@anchor{393} @section @code{GNAT.Serial_Communications} (@code{g-sercom.ads}) @@ -24906,7 +24664,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{3ab}@anchor{gnat_rm/the_gnat_library id108}@anchor{3ac} +@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id97}@anchor{395} @section @code{GNAT.SHA1} (@code{g-sha1.ads}) @@ -24919,7 +24677,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{3ad}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ae} +@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id98}@anchor{397} @section @code{GNAT.SHA224} (@code{g-sha224.ads}) @@ -24932,7 +24690,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{3af}@anchor{gnat_rm/the_gnat_library id110}@anchor{3b0} +@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{398}@anchor{gnat_rm/the_gnat_library id99}@anchor{399} @section @code{GNAT.SHA256} (@code{g-sha256.ads}) @@ -24945,7 +24703,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{3b1}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b2} +@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id100}@anchor{39b} @section @code{GNAT.SHA384} (@code{g-sha384.ads}) @@ -24958,7 +24716,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{3b3}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b4} +@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{39c}@anchor{gnat_rm/the_gnat_library id101}@anchor{39d} @section @code{GNAT.SHA512} (@code{g-sha512.ads}) @@ -24971,7 +24729,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{3b5}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b6} +@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id102}@anchor{39f} @section @code{GNAT.Signals} (@code{g-signal.ads}) @@ -24983,7 +24741,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{3b7}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b8} +@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{3a0}@anchor{gnat_rm/the_gnat_library id103}@anchor{3a1} @section @code{GNAT.Sockets} (@code{g-socket.ads}) @@ -24998,7 +24756,7 @@ on all native GNAT ports and on VxWorks cross prots. 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{3b9}@anchor{gnat_rm/the_gnat_library id115}@anchor{3ba} +@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{3a2}@anchor{gnat_rm/the_gnat_library id104}@anchor{3a3} @section @code{GNAT.Source_Info} (@code{g-souinf.ads}) @@ -25012,7 +24770,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{3bb}@anchor{gnat_rm/the_gnat_library id116}@anchor{3bc} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{3a4}@anchor{gnat_rm/the_gnat_library id105}@anchor{3a5} @section @code{GNAT.Spelling_Checker} (@code{g-speche.ads}) @@ -25024,7 +24782,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{3bd}@anchor{gnat_rm/the_gnat_library id117}@anchor{3be} +@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id106}@anchor{3a7} @section @code{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads}) @@ -25037,7 +24795,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{3bf}@anchor{gnat_rm/the_gnat_library id118}@anchor{3c0} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id107}@anchor{3a9} @section @code{GNAT.Spitbol.Patterns} (@code{g-spipat.ads}) @@ -25053,7 +24811,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{3c1}@anchor{gnat_rm/the_gnat_library id119}@anchor{3c2} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{3aa}@anchor{gnat_rm/the_gnat_library id108}@anchor{3ab} @section @code{GNAT.Spitbol} (@code{g-spitbo.ads}) @@ -25068,7 +24826,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{3c3}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c4} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id109}@anchor{3ad} @section @code{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads}) @@ -25083,7 +24841,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{3c5}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c6} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id110}@anchor{3af} @section @code{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads}) @@ -25100,7 +24858,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{3c7}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c8} +@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id111}@anchor{3b1} @section @code{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads}) @@ -25117,7 +24875,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{3c9}@anchor{gnat_rm/the_gnat_library id123}@anchor{3ca} +@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id112}@anchor{3b3} @section @code{GNAT.SSE} (@code{g-sse.ads}) @@ -25129,7 +24887,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{3cb}@anchor{gnat_rm/the_gnat_library id124}@anchor{3cc} +@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id113}@anchor{3b5} @section @code{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads}) @@ -25138,7 +24896,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{3cd}@anchor{gnat_rm/the_gnat_library id125}@anchor{3ce} +@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3b6}@anchor{gnat_rm/the_gnat_library id114}@anchor{3b7} @section @code{GNAT.String_Hash} (@code{g-strhas.ads}) @@ -25150,7 +24908,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{3cf}@anchor{gnat_rm/the_gnat_library id126}@anchor{3d0} +@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id115}@anchor{3b9} @section @code{GNAT.Strings} (@code{g-string.ads}) @@ -25160,7 +24918,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{3d1}@anchor{gnat_rm/the_gnat_library id127}@anchor{3d2} +@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3ba}@anchor{gnat_rm/the_gnat_library id116}@anchor{3bb} @section @code{GNAT.String_Split} (@code{g-strspl.ads}) @@ -25174,7 +24932,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{3d3}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d4} +@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id117}@anchor{3bd} @section @code{GNAT.Table} (@code{g-table.ads}) @@ -25194,7 +24952,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{3d5}@anchor{gnat_rm/the_gnat_library id129}@anchor{3d6} +@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id118}@anchor{3bf} @section @code{GNAT.Task_Lock} (@code{g-tasloc.ads}) @@ -25211,7 +24969,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{3d7}@anchor{gnat_rm/the_gnat_library id130}@anchor{3d8} +@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id119}@anchor{3c1} @section @code{GNAT.Time_Stamp} (@code{g-timsta.ads}) @@ -25226,7 +24984,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{3d9}@anchor{gnat_rm/the_gnat_library id131}@anchor{3da} +@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id120}@anchor{3c3} @section @code{GNAT.Threads} (@code{g-thread.ads}) @@ -25243,7 +25001,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{3db}@anchor{gnat_rm/the_gnat_library id132}@anchor{3dc} +@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id121}@anchor{3c5} @section @code{GNAT.Traceback} (@code{g-traceb.ads}) @@ -25255,7 +25013,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-table ads,GNAT Traceback g-traceb ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3dd}@anchor{gnat_rm/the_gnat_library id133}@anchor{3de} +@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id122}@anchor{3c7} @section @code{GNAT.Traceback.Symbolic} (@code{g-trasym.ads}) @@ -25264,7 +25022,7 @@ in various debugging situations. @geindex Trace back facilities @node GNAT UTF_32 g-table ads,GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3df}@anchor{gnat_rm/the_gnat_library id134}@anchor{3e0} +@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3c8}@anchor{gnat_rm/the_gnat_library id123}@anchor{3c9} @section @code{GNAT.UTF_32} (@code{g-table.ads}) @@ -25283,7 +25041,7 @@ lower case to upper case fold routine corresponding to the Ada 2005 rules for identifier equivalence. @node GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-table ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3e1}@anchor{gnat_rm/the_gnat_library id135}@anchor{3e2} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id124}@anchor{3cb} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads}) @@ -25296,7 +25054,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 Wide_Spelling_Checker g-u3spch ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3e3}@anchor{gnat_rm/the_gnat_library id136}@anchor{3e4} +@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id125}@anchor{3cd} @section @code{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads}) @@ -25308,7 +25066,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{3e5}@anchor{gnat_rm/the_gnat_library id137}@anchor{3e6} +@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id126}@anchor{3cf} @section @code{GNAT.Wide_String_Split} (@code{g-wistsp.ads}) @@ -25322,7 +25080,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{3e7}@anchor{gnat_rm/the_gnat_library id138}@anchor{3e8} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id127}@anchor{3d1} @section @code{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads}) @@ -25334,7 +25092,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{3e9}@anchor{gnat_rm/the_gnat_library id139}@anchor{3ea} +@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3d2}@anchor{gnat_rm/the_gnat_library id128}@anchor{3d3} @section @code{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads}) @@ -25348,7 +25106,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 id140}@anchor{3eb}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3ec} +@anchor{gnat_rm/the_gnat_library id129}@anchor{3d4}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3d5} @section @code{Interfaces.C.Extensions} (@code{i-cexten.ads}) @@ -25359,7 +25117,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 id141}@anchor{3ed}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3ee} +@anchor{gnat_rm/the_gnat_library id130}@anchor{3d6}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3d7} @section @code{Interfaces.C.Streams} (@code{i-cstrea.ads}) @@ -25372,7 +25130,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 id142}@anchor{3ef}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3f0} +@anchor{gnat_rm/the_gnat_library id131}@anchor{3d8}@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3d9} @section @code{Interfaces.Packed_Decimal} (@code{i-pacdec.ads}) @@ -25387,7 +25145,7 @@ from a packed decimal format compatible with that used on IBM mainframes. @node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id143}@anchor{3f1}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3f2} +@anchor{gnat_rm/the_gnat_library id132}@anchor{3da}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3db} @section @code{Interfaces.VxWorks} (@code{i-vxwork.ads}) @@ -25403,7 +25161,7 @@ In particular, it interfaces with the VxWorks hardware interrupt facilities. @node Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces VxWorks i-vxwork ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id144}@anchor{3f3}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3f4} +@anchor{gnat_rm/the_gnat_library id133}@anchor{3dc}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3dd} @section @code{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads}) @@ -25419,7 +25177,7 @@ intConnect() with a custom routine for installing interrupt handlers. @node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks Int_Connection i-vxinco ads,The GNAT Library -@anchor{gnat_rm/the_gnat_library id145}@anchor{3f5}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3f6} +@anchor{gnat_rm/the_gnat_library id134}@anchor{3de}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3df} @section @code{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads}) @@ -25442,7 +25200,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 id146}@anchor{3f7}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3f8} +@anchor{gnat_rm/the_gnat_library id135}@anchor{3e0}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3e1} @section @code{System.Address_Image} (@code{s-addima.ads}) @@ -25458,7 +25216,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 id147}@anchor{3f9}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3fa} +@anchor{gnat_rm/the_gnat_library id136}@anchor{3e2}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3e3} @section @code{System.Assertions} (@code{s-assert.ads}) @@ -25474,7 +25232,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 id148}@anchor{3fb}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3fc} +@anchor{gnat_rm/the_gnat_library id137}@anchor{3e4}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3e5} @section @code{System.Atomic_Counters} (@code{s-atocou.ads}) @@ -25488,7 +25246,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 id149}@anchor{3fd}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3fe} +@anchor{gnat_rm/the_gnat_library id138}@anchor{3e6}@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3e7} @section @code{System.Memory} (@code{s-memory.ads}) @@ -25506,7 +25264,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 id150}@anchor{3ff}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{400} +@anchor{gnat_rm/the_gnat_library id139}@anchor{3e8}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3e9} @section @code{System.Multiprocessors} (@code{s-multip.ads}) @@ -25519,7 +25277,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 id151}@anchor{401}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{402} +@anchor{gnat_rm/the_gnat_library id140}@anchor{3ea}@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3eb} @section @code{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads}) @@ -25532,7 +25290,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 id152}@anchor{403}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{404} +@anchor{gnat_rm/the_gnat_library id141}@anchor{3ec}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3ed} @section @code{System.Partition_Interface} (@code{s-parint.ads}) @@ -25545,7 +25303,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 id153}@anchor{405}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{406} +@anchor{gnat_rm/the_gnat_library id142}@anchor{3ee}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3ef} @section @code{System.Pool_Global} (@code{s-pooglo.ads}) @@ -25562,7 +25320,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 id154}@anchor{407}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{408} +@anchor{gnat_rm/the_gnat_library id143}@anchor{3f0}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3f1} @section @code{System.Pool_Local} (@code{s-pooloc.ads}) @@ -25579,7 +25337,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 id155}@anchor{409}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{40a} +@anchor{gnat_rm/the_gnat_library id144}@anchor{3f2}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3f3} @section @code{System.Restrictions} (@code{s-restri.ads}) @@ -25595,7 +25353,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 id156}@anchor{40b}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{40c} +@anchor{gnat_rm/the_gnat_library id145}@anchor{3f4}@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3f5} @section @code{System.Rident} (@code{s-rident.ads}) @@ -25611,7 +25369,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 id157}@anchor{40d}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{40e} +@anchor{gnat_rm/the_gnat_library id146}@anchor{3f6}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3f7} @section @code{System.Strings.Stream_Ops} (@code{s-ststop.ads}) @@ -25627,7 +25385,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 id158}@anchor{40f}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{410} +@anchor{gnat_rm/the_gnat_library id147}@anchor{3f8}@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3f9} @section @code{System.Unsigned_Types} (@code{s-unstyp.ads}) @@ -25640,7 +25398,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 id159}@anchor{411}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{412} +@anchor{gnat_rm/the_gnat_library id148}@anchor{3fa}@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3fb} @section @code{System.Wch_Cnv} (@code{s-wchcnv.ads}) @@ -25661,7 +25419,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 id160}@anchor{413}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{414} +@anchor{gnat_rm/the_gnat_library id149}@anchor{3fc}@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{3fd} @section @code{System.Wch_Con} (@code{s-wchcon.ads}) @@ -25673,7 +25431,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{3fe}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{3ff}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11} @chapter Interfacing to Other Languages @@ -25691,7 +25449,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{400}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{401} @section Interfacing to C @@ -25831,7 +25589,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{47}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{419} +@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{47}@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{402} @section Interfacing to C++ @@ -25888,7 +25646,7 @@ The @code{External_Name} is the name of the C++ RTTI symbol. You can then cover a specific C++ exception in an exception handler. @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{403}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{404} @section Interfacing to COBOL @@ -25896,7 +25654,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{405}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{406} @section Interfacing to Fortran @@ -25906,7 +25664,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{407}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{408} @section Interfacing to non-GNAT Ada code @@ -25930,7 +25688,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{409}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{40a}@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12} @chapter Specialized Needs Annexes @@ -25971,7 +25729,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{40b}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{40c}@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13} @chapter Implementation of Specific Ada Features @@ -25990,7 +25748,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{166} +@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{40d}@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{166} @section Machine Code Insertions @@ -26158,7 +25916,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{40e}@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{40f} @section GNAT Implementation of Tasking @@ -26174,7 +25932,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{410}@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{411} @subsection Mapping Ada Tasks onto the Underlying Kernel Threads @@ -26243,7 +26001,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{412}@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{413} @subsection Ensuring Compliance with the Real-Time Annex @@ -26294,7 +26052,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{414} @subsection Support for Locking Policies @@ -26328,7 +26086,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{415}@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{416} @section GNAT Implementation of Shared Passive Packages @@ -26426,7 +26184,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{417}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{418} @section Code Generation for Array Aggregates @@ -26457,7 +26215,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{419}@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{41a} @subsection Static constant aggregates with static bounds @@ -26504,7 +26262,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{41b}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{41c} @subsection Constant aggregates with unconstrained nominal types @@ -26519,7 +26277,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{41d}@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{41e} @subsection Aggregates with static bounds @@ -26547,7 +26305,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{41f}@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{420} @subsection Aggregates with nonstatic bounds @@ -26558,7 +26316,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{421}@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{422} @subsection Aggregates in assignment statements @@ -26600,7 +26358,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{423}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{424} @section The Size of Discriminated Records with Default Discriminants @@ -26680,7 +26438,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{425}@anchor{gnat_rm/implementation_of_specific_ada_features image-values-for-nonscalar-types}@anchor{426} @section Image Values For Nonscalar Types @@ -26700,7 +26458,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{427}@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{428} @section Strict Conformance to the Ada Reference Manual @@ -26727,7 +26485,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,Security Hardening Features,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{429}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{42a}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14} @chapter Implementation of Ada 2012 Features @@ -28893,7 +28651,7 @@ RM References: H.04 (8/1) @end itemize @node Security Hardening Features,Obsolescent Features,Implementation of Ada 2012 Features,Top -@anchor{gnat_rm/security_hardening_features doc}@anchor{442}@anchor{gnat_rm/security_hardening_features id1}@anchor{443}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} +@anchor{gnat_rm/security_hardening_features doc}@anchor{42b}@anchor{gnat_rm/security_hardening_features id1}@anchor{42c}@anchor{gnat_rm/security_hardening_features security-hardening-features}@anchor{15} @chapter Security Hardening Features @@ -28915,7 +28673,7 @@ change. @end menu @node Register Scrubbing,Stack Scrubbing,,Security Hardening Features -@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{444} +@anchor{gnat_rm/security_hardening_features register-scrubbing}@anchor{42d} @section Register Scrubbing @@ -28945,7 +28703,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{445} +@anchor{gnat_rm/security_hardening_features stack-scrubbing}@anchor{42e} @section Stack Scrubbing @@ -29040,7 +28798,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{446} +@anchor{gnat_rm/security_hardening_features hardened-conditionals}@anchor{42f} @section Hardened Conditionals @@ -29087,7 +28845,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{447} +@anchor{gnat_rm/security_hardening_features hardened-booleans}@anchor{430} @section Hardened Booleans @@ -29128,7 +28886,7 @@ For usage and more details on that attribute, see @cite{Using the GNU Compiler C @c Control Flow Redundancy: @node Control Flow Redundancy,,Hardened Booleans,Security Hardening Features -@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{448} +@anchor{gnat_rm/security_hardening_features control-flow-redundancy}@anchor{431} @section Control Flow Redundancy @@ -29177,7 +28935,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{449}@anchor{gnat_rm/obsolescent_features id1}@anchor{44a}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} +@anchor{gnat_rm/obsolescent_features doc}@anchor{432}@anchor{gnat_rm/obsolescent_features id1}@anchor{433}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{16} @chapter Obsolescent Features @@ -29196,7 +28954,7 @@ compatibility purposes. @end menu @node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features -@anchor{gnat_rm/obsolescent_features id2}@anchor{44b}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{44c} +@anchor{gnat_rm/obsolescent_features id2}@anchor{434}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{435} @section pragma No_Run_Time @@ -29209,7 +28967,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{44d}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{44e} +@anchor{gnat_rm/obsolescent_features id3}@anchor{436}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{437} @section pragma Ravenscar @@ -29218,7 +28976,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{44f}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{450} +@anchor{gnat_rm/obsolescent_features id4}@anchor{438}@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{439} @section pragma Restricted_Run_Time @@ -29228,7 +28986,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{451}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{452} +@anchor{gnat_rm/obsolescent_features id5}@anchor{43a}@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{43b} @section pragma Task_Info @@ -29254,7 +29012,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{453}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{454} +@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{43c}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{43d} @section package System.Task_Info (@code{s-tasinf.ads}) @@ -29264,7 +29022,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{455}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{456} +@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{43e}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{17}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{43f} @chapter Compatibility and Porting Guide @@ -29286,7 +29044,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{457}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{458} +@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{440}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{441} @section Writing Portable Fixed-Point Declarations @@ -29408,7 +29166,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{459}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{45a} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{442}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{443} @section Compatibility with Ada 83 @@ -29436,7 +29194,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{45b}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{45c} +@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{444}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{445} @subsection Legal Ada 83 programs that are illegal in Ada 95 @@ -29536,7 +29294,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{45d}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{45e} +@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{446}@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{447} @subsection More deterministic semantics @@ -29564,7 +29322,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{45f}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{460} +@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{448}@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{449} @subsection Changed semantics @@ -29606,7 +29364,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{461}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{462} +@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{44a}@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{44b} @subsection Other language compatibility issues @@ -29639,7 +29397,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{463}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{464} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{44c}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{44d} @section Compatibility between Ada 95 and Ada 2005 @@ -29711,7 +29469,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{465}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{466} +@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{44e}@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{44f} @section Implementation-dependent characteristics @@ -29734,7 +29492,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{467}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{468} +@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{450}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{451} @subsection Implementation-defined pragmas @@ -29756,7 +29514,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{469}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{46a} +@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{452}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{453} @subsection Implementation-defined attributes @@ -29770,7 +29528,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{46b}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{46c} +@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{454}@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{455} @subsection Libraries @@ -29799,7 +29557,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{46d}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{46e} +@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{456}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{457} @subsection Elaboration order @@ -29835,7 +29593,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{46f}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{470} +@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{458}@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{459} @subsection Target-specific aspects @@ -29848,10 +29606,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{471,,Representation Clauses}. +GNAT’s approach to these issues is described in @ref{45a,,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{472}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{473} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{45b}@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{45c} @section Compatibility with Other Ada Systems @@ -29894,7 +29652,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{474}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{471} +@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{45d}@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{45a} @section Representation Clauses @@ -29987,7 +29745,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{475}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{476} +@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{45e}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{45f} @section Compatibility with HP Ada 83 @@ -30017,7 +29775,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{477}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{478} +@anchor{share/gnu_free_documentation_license doc}@anchor{460}@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{461} @chapter GNU Free Documentation License diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index e1a4192..f2cb1ed 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -19,7 +19,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Aug 25, 2022 +GNAT User's Guide for Native Platforms , Sep 09, 2022 AdaCore @@ -12984,7 +12984,7 @@ to the default checks required by Ada as described above. All validity checks are turned on. That is, @code{-gnatVa} is -equivalent to @code{gnatVcdfimoprst}. +equivalent to @code{gnatVcdefimoprst}. @end table @geindex -gnatVc (gcc) @@ -12996,8 +12996,8 @@ equivalent to @code{gnatVcdfimoprst}. `Validity checks for copies.' -The right hand side of assignments, and the initializing values of -object declarations are validity checked. +The right-hand side of assignments, and the (explicit) initializing values +of object declarations are validity checked. @end table @geindex -gnatVd (gcc) @@ -13009,12 +13009,14 @@ object declarations are validity checked. `Default (RM) validity checks.' -Some validity checks are done by default following normal Ada semantics -(RM 13.9.1 (9-11)). -A check is done in case statements that the expression is within the range -of the subtype. If it is not, Constraint_Error is raised. -For assignments to array components, a check is done that the expression used -as index is within the range. If it is not, Constraint_Error is raised. +Some validity checks are required by Ada (see RM 13.9.1 (9-11)); these +(and only these) validity checks are enabled by default. +For case statements (and case expressions) that lack a “when others =>” +choice, a check is made that the value of the selector expression +belongs to its nominal subtype. If it does not, Constraint_Error is raised. +For assignments to array components (and for indexed components in some +other contexts), a check is made that each index expression belongs to the +corresponding index subtype. If it does not, Constraint_Error is raised. Both these validity checks may be turned off using switch @code{-gnatVD}. They are turned on by default. If @code{-gnatVD} is specified, a subsequent switch @code{-gnatVd} will leave the checks turned on. @@ -13031,16 +13033,13 @@ overwriting may occur. @item @code{-gnatVe} -`Validity checks for elementary components.' +`Validity checks for scalar components.' -In the absence of this switch, assignments to record or array components are -not validity checked, even if validity checks for assignments generally -(@code{-gnatVc}) are turned on. In Ada, assignment of composite values do not -require valid data, but assignment of individual components does. So for -example, there is a difference between copying the elements of an array with a -slice assignment, compared to assigning element by element in a loop. This -switch allows you to turn off validity checking for components, even when they -are assigned component by component. +In the absence of this switch, assignments to scalar components of +enclosing record or array objects are not validity checked, even if +validity checks for assignments generally (@code{-gnatVc}) are turned on. +Specifying this switch enables such checks. +This switch has no effect if the @code{-gnatVc} switch is not specified. @end table @geindex -gnatVf (gcc) @@ -13052,11 +13051,18 @@ are assigned component by component. `Validity checks for floating-point values.' -In the absence of this switch, validity checking occurs only for discrete -values. If @code{-gnatVf} is specified, then validity checking also applies +Specifying this switch enables validity checking for floating-point +values in the same contexts where validity checking is enabled for +other scalar values. +In the absence of this switch, validity checking is not performed for +floating-point values. This takes precedence over other statements about +performing validity checking for scalar objects in various scenarios. +One way to look at it is that if this switch is not set, then whenever +any of the other rules in this section use the word “scalar” they +really mean “scalar and not floating-point”. +If @code{-gnatVf} is specified, then validity checking also applies for floating-point values, and NaNs and infinities are considered invalid, -as well as out of range values for constrained types. Note that this means -that standard IEEE infinity mode is not allowed. The exact contexts +as well as out-of-range values for constrained types. The exact contexts in which floating-point values are checked depends on the setting of other options. For example, @code{-gnatVif} or @code{-gnatVfi} (the order does not matter) specifies that floating-point parameters of mode @@ -13119,7 +13125,8 @@ is used, it cancels any other @code{-gnatV} previously issued. `Validity checks for operator and attribute operands.' -Arguments for predefined operators and attributes are validity checked. +Scalar arguments for predefined operators and for attributes are +validity checked. This includes all operators in package @code{Standard}, the shift operators defined as intrinsic in package @code{Interfaces} and operands for attributes such as @code{Pos}. Checks are also made @@ -13137,14 +13144,15 @@ also made on explicit ranges using @code{..} (e.g., slices, loops etc). `Validity checks for parameters.' -This controls the treatment of parameters within a subprogram (as opposed -to @code{-gnatVi} and @code{-gnatVm} which control validity testing -of parameters on a call. If either of these call options is used, then -normally an assumption is made within a subprogram that the input arguments -have been validity checking at the point of call, and do not need checking -again within a subprogram). If @code{-gnatVp} is set, then this assumption -is not made, and parameters are not assumed to be valid, so their validity -will be checked (or rechecked) within the subprogram. +This controls the treatment of formal parameters within a subprogram (as +opposed to @code{-gnatVi} and @code{-gnatVm}, which control validity +testing of actual parameters of a call). If either of these call options is +specified, then normally an assumption is made within a subprogram that +the validity of any incoming formal parameters of the corresponding mode(s) +has already been checked at the point of call and does not need rechecking. +If @code{-gnatVp} is set, then this assumption is not made and so their +validity may be checked (or rechecked) within the subprogram. If neither of +the two call-related options is specified, then this switch has no effect. @end table @geindex -gnatVr (gcc) @@ -13156,7 +13164,7 @@ will be checked (or rechecked) within the subprogram. `Validity checks for function returns.' -The expression in @code{return} statements in functions is validity +The expression in simple @code{return} statements in functions is validity checked. @end table @@ -13169,9 +13177,10 @@ checked. `Validity checks for subscripts.' -All subscripts expressions are checked for validity, whether they appear -on the right side or left side (in default mode only left side subscripts -are validity checked). +All subscript expressions are checked for validity, whatever context +they occur in (in default mode some subscripts are not validity checked; +for example, validity checking may be omitted in some cases involving +a read of a component of an array). @end table @geindex -gnatVt (gcc) diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index 343a9db..6562c12 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -605,19 +605,7 @@ package body Impunit is -- GNAT Defined Additions to Ada 2012 -- ---------------------------------------- - ("a-cfidll", F), -- Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists - ("a-cfinse", F), -- Ada.Containers.Functional_Infinite_Sequences - ("a-cfinve", F), -- Ada.Containers.Formal_Indefinite_Vectors ("a-coboho", F), -- Ada.Containers.Bounded_Holders - ("a-cofove", F), -- Ada.Containers.Formal_Vectors - ("a-cofuma", F), -- Ada.Containers.Functional_Maps - ("a-cofuse", F), -- Ada.Containers.Functional_Sets - ("a-cofuve", F), -- Ada.Containers.Functional_Vectors - ("a-cfdlli", F), -- Ada.Containers.Formal_Doubly_Linked_Lists - ("a-cforse", F), -- Ada.Containers.Formal_Ordered_Sets - ("a-cforma", F), -- Ada.Containers.Formal_Ordered_Maps - ("a-cfhase", F), -- Ada.Containers.Formal_Hashed_Sets - ("a-cfhama", F), -- Ada.Containers.Formal_Hashed_Maps ("a-cvgpso", F) -- Ada.Containers.Vectors.Generic_Parallel_Sorting from ); -- GNATCOLL.OMP diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index e32df68..e3f35da 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -3257,7 +3257,7 @@ package body Inline is pragma Assert (Modify_Tree_For_C and then Is_Subprogram (Enclosing_Subp) - and then Present (Postconditions_Proc (Enclosing_Subp))); + and then Present (Wrapped_Statements (Enclosing_Subp))); if Ekind (Enclosing_Subp) = E_Function then if Nkind (First (Parameter_Associations (N))) in @@ -3367,6 +3367,8 @@ package body Inline is E : Entity_Id; Ret : Node_Id; + Had_Private_View : Boolean; + begin if Is_Entity_Name (N) and then Present (Entity (N)) then E := Entity (N); @@ -3380,13 +3382,21 @@ package body Inline is -- subtype is private at the call point but its full view is -- visible to the body, then the inlined tree here must be -- analyzed with the full view). + -- + -- The Has_Private_View flag is cleared by rewriting, so it + -- must be explicitly saved and restored, just like when + -- instantiating the body to inline. if Is_Entity_Name (A) then + Had_Private_View := Has_Private_View (N); Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N))); + Set_Has_Private_View (N, Had_Private_View); Check_Private_View (N); elsif Nkind (A) = N_Defining_Identifier then + Had_Private_View := Has_Private_View (N); Rewrite (N, New_Occurrence_Of (A, Sloc (N))); + Set_Has_Private_View (N, Had_Private_View); Check_Private_View (N); -- Numeric literal @@ -3841,7 +3851,7 @@ package body Inline is if Modify_Tree_For_C and then Nkind (N) = N_Procedure_Call_Statement - and then Chars (Name (N)) = Name_uPostconditions + and then Chars (Name (N)) = Name_uWrapped_Statements then Declare_Postconditions_Result; end if; @@ -4536,13 +4546,14 @@ package body Inline is Decl : Node_Id; begin - if No (E_Body) then -- imported subprogram + if No (E_Body) then -- imported subprogram return False; else Decl := First (Declarations (E_Body)); while Present (Decl) loop if Nkind (Decl) = N_Full_Type_Declaration + and then Comes_From_Source (Decl) and then Present (Init_Proc (Defining_Identifier (Decl))) then return True; @@ -4698,8 +4709,9 @@ package body Inline is procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id) is function Replace_Formal (N : Node_Id) return Traverse_Result; - -- Replace each occurrence of a formal with the corresponding actual, - -- using the mapping created by Establish_Mapping_For_Inlined_Call. + -- Replace each occurrence of a formal with the + -- corresponding actual, using the mapping created + -- by Establish_Actual_Mapping_For_Inlined_Call. function Reset_Sloc (Nod : Node_Id) return Traverse_Result; -- Reset the Sloc of a node to that of the call itself, so that errors diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index a4ff69a..043444c 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -618,15 +618,6 @@ package body Lib.Xref is end if; end if; - -- Do not generate references if we are within a postcondition sub- - -- program, because the reference does not comes from source, and the - -- preanalysis of the aspect has already created an entry for the ALI - -- file at the proper source location. - - if Chars (Current_Scope) = Name_uPostconditions then - return; - end if; - -- Never collect references if not in main source unit. However, we omit -- this test if Typ is 'e' or 'k', since these entries are structural, -- and it is useful to have them in units that reference packages as diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb index 6c51cc7..691d8e4 100644 --- a/gcc/ada/lib.adb +++ b/gcc/ada/lib.adb @@ -992,6 +992,15 @@ package body Lib is return Is_Predefined_Renaming (Unit); end In_Predefined_Renaming; + --------- + -- ipu -- + --------- + + function ipu (N : Node_Or_Entity_Id) return Boolean is + begin + return In_Predefined_Unit (N); + end ipu; + ------------------------ -- In_Predefined_Unit -- ------------------------ diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index e29d42a..c308ac1 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -633,6 +633,12 @@ package Lib is function In_Extended_Main_Source_Unit (Loc : Source_Ptr) return Boolean; -- Same function as above, but argument is a source pointer + function ipu (N : Node_Or_Entity_Id) return Boolean; + -- Same as In_Predefined_Unit, but renamed so it can assist debugging. + -- Otherwise, there is a disambiguous name conflict in the two versions of + -- In_Predefined_Unit which makes it inconvient to set as a breakpoint + -- condition. + function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean; -- Returns True if the given node or entity appears within the source text -- of a predefined unit (i.e. within Ada, Interfaces, System or within one diff --git a/gcc/ada/libgnarl/s-tpoben.ads b/gcc/ada/libgnarl/s-tpoben.ads index 2fd91ac..c6866f9 100644 --- a/gcc/ada/libgnarl/s-tpoben.ads +++ b/gcc/ada/libgnarl/s-tpoben.ads @@ -189,14 +189,19 @@ package System.Tasking.Protected_Objects.Entries is -- Lock a protected object for write access. Upon return, the caller owns -- the lock to this object, and no other call to Lock or Lock_Read_Only -- with the same argument will return until the corresponding call to - -- Unlock has been made by the caller. Program_Error is raised in case of - -- ceiling violation. + -- Unlock has been made by the caller. Program_Error is raised in case + -- of ceiling violation, or if the protected object has already been + -- finalized, or if Detect_Blocking is true and the protected object + -- is already locked by the current task. In the Program_Error cases, + -- the object is not locked. procedure Lock_Entries_With_Status (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean); -- Same as above, but return the ceiling violation status instead of - -- raising Program_Error. + -- raising Program_Error. This raises Program_Error in the other + -- cases mentioned for Lock_Entries. In the Program_Error cases, + -- the object is not locked. procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access); -- Lock a protected object for read access. Upon return, the caller owns diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb deleted file mode 100644 index bbb8fd4..0000000 --- a/gcc/ada/libgnat/a-cfdlli.adb +++ /dev/null @@ -1,1905 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2022, 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; - -with System; use type System.Address; - -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; - -package body Ada.Containers.Formal_Doubly_Linked_Lists with - SPARK_Mode => Off -is - -- Convert Count_Type to Big_Interger - - package Conversions is new Signed_Conversions (Int => Count_Type); - use Conversions; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type); - - procedure Free (Container : in out List; X : Count_Type); - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type); - - function Vet (L : List; Position : Cursor) return Boolean with Inline; - - --------- - -- "=" -- - --------- - - function "=" (Left : List; Right : List) return Boolean is - LI : Count_Type; - RI : Count_Type; - - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Length /= Right.Length then - return False; - end if; - - LI := Left.First; - RI := Right.First; - while LI /= 0 loop - if Left.Nodes (LI).Element /= Right.Nodes (RI).Element then - return False; - end if; - - LI := Left.Nodes (LI).Next; - RI := Right.Nodes (RI).Next; - end loop; - - return True; - end "="; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Free >= 0 then - New_Node := Container.Free; - N (New_Node).Element := New_Item; - Container.Free := N (New_Node).Next; - - else - New_Node := abs Container.Free; - N (New_Node).Element := New_Item; - Container.Free := Container.Free - 1; - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out List; New_Item : Element_Type) is - begin - Insert (Container, No_Element, New_Item, 1); - end Append; - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, No_Element, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out List; Source : List) is - N : Node_Array renames Source.Nodes; - J : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - J := Source.First; - while J /= 0 loop - Append (Target, N (J).Element, 1); - J := N (J).Next; - end loop; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Container.Length = 0 then - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - return; - end if; - - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - while Container.Length > 1 loop - X := Container.First; - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - - X := Container.First; - - Container.First := 0; - Container.Last := 0; - Container.Length := 0; - - Free (Container, X); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return not null access constant Element_Type - is - begin - if not Has_Element (Container => Container, Position => Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return Container.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : List; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : List; - Capacity : Count_Type := 0) return List - is - C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); - N : Count_Type; - P : List (C); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - N := 1; - while N <= Source.Capacity loop - P.Nodes (N).Prev := Source.Nodes (N).Prev; - P.Nodes (N).Next := Source.Nodes (N).Next; - P.Nodes (N).Element := Source.Nodes (N).Element; - N := N + 1; - end loop; - - P.Free := Source.Free; - P.Length := Source.Length; - P.First := Source.First; - P.Last := Source.Last; - - if P.Free >= 0 then - N := Source.Capacity + 1; - while N <= C loop - Free (P, N); - N := N + 1; - end loop; - end if; - - return P; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out List; Position : in out Cursor) is - begin - Delete - (Container => Container, - Position => Position, - Count => 1); - end Delete; - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if not Has_Element (Container => Container, - Position => Position) - then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; - return; - end if; - - if Count = 0 then - Position := No_Element; - return; - end if; - - for Index in 1 .. Count loop - pragma Assert (Container.Length >= 2); - - X := Position.Node; - Container.Length := Container.Length - 1; - - if X = Container.Last then - Position := No_Element; - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Free (Container, X); - return; - end if; - - Position.Node := N (X).Next; - pragma Assert (N (Position.Node).Prev >= 0); - - N (N (X).Next).Prev := N (X).Prev; - N (N (X).Prev).Next := N (X).Next; - - Free (Container, X); - end loop; - - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out List) is - begin - Delete_First - (Container => Container, - Count => 1); - end Delete_First; - - procedure Delete_First (Container : in out List; Count : Count_Type) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - for J in 1 .. Count loop - X := Container.First; - pragma Assert (N (N (X).Next).Prev = Container.First); - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out List) is - begin - Delete_Last - (Container => Container, - Count => 1); - end Delete_Last; - - procedure Delete_Last (Container : in out List; Count : Count_Type) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (N (N (X).Prev).Next = Container.Last); - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : List; - Position : Cursor) return Element_Type - is - begin - if not Has_Element (Container => Container, Position => Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return Container.Nodes (Position.Node).Element; - end Element; - - ---------- - -- Find -- - ---------- - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - From : Count_Type := Position.Node; - - begin - if From = 0 and Container.Length = 0 then - return No_Element; - end if; - - if From = 0 then - From := Container.First; - end if; - - if Position.Node /= 0 and then not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - while From /= 0 loop - if Container.Nodes (From).Element = Item then - return (Node => From); - end if; - - From := Container.Nodes (From).Next; - end loop; - - return No_Element; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : List) return Cursor is - begin - if Container.First = 0 then - return No_Element; - end if; - - return (Node => Container.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : List) return Element_Type is - F : constant Count_Type := Container.First; - - begin - if F = 0 then - raise Constraint_Error with "list is empty"; - else - return Container.Nodes (F).Element; - end if; - end First_Element; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : List) is null; - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - Elem : Element_Type; - - begin - for Index in 1 .. M.Length (Container) loop - Elem := Element (Container, Index); - - if not M.Contains (Left, 1, M.Length (Left), Elem) - and then not M.Contains (Right, 1, M.Length (Right), Elem) - then - return False; - end if; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Positive_Count_Type := 1; - L_Lst : Count_Type; - Right : M.Sequence; - R_Fst : Positive_Count_Type := 1; - R_Lst : Count_Type) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Count_Type := R_Fst - 1; - - begin - while not Found and J < R_Lst loop - J := J + 1; - if Element (Left, I) = Element (Right, J) then - Found := True; - end if; - end loop; - - if not Found then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_Included; - - ------------------------- - -- M_Elements_Reversed -- - ------------------------- - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - is - L : constant Count_Type := M.Length (Left); - - begin - if L /= M.Length (Right) then - return False; - end if; - - for I in 1 .. L loop - if Element (Left, I) /= Element (Right, L - I + 1) then - return False; - end if; - end loop; - - return True; - end M_Elements_Reversed; - - ------------------------ - -- M_Elements_Swapped -- - ------------------------ - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Positive_Count_Type; - Y : Positive_Count_Type) return Boolean - is - begin - if M.Length (Left) /= M.Length (Right) - or else Element (Left, X) /= Element (Right, Y) - or else Element (Left, Y) /= Element (Right, X) - then - return False; - end if; - - for I in 1 .. M.Length (Left) loop - if I /= X and then I /= Y - and then Element (Left, I) /= Element (Right, I) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Swapped; - - ----------- - -- Model -- - ----------- - - function Model (Container : List) return M.Sequence is - Position : Count_Type := Container.First; - R : M.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := M.Add (R, Container.Nodes (Position).Element); - Position := Container.Nodes (Position).Next; - end loop; - - return R; - end Model; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (M_Left : M.Sequence; - M_Right : M.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > M.Length (M_Left) - or else P.Get (P_Right, C) > M.Length (M_Right) - or else M.Get (M_Left, P.Get (P_Left, C)) /= - M.Get (M_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - for C of P_Right loop - if not P.Has_Key (P_Left, C) then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------- - -- P_Positions_Shifted -- - ------------------------- - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) + Count - then - return False; - end if; - - else - if P.Has_Key (Small, Cu) then - return False; - end if; - end if; - end; - end loop; - - return True; - end P_Positions_Shifted; - - ------------------------- - -- P_Positions_Swapped -- - ------------------------- - - function P_Positions_Swapped - (Left : P.Map; - Right : P.Map; - X : Cursor; - Y : Cursor) return Boolean - is - begin - if not P.Has_Key (Left, X) - or not P.Has_Key (Left, Y) - or not P.Has_Key (Right, X) - or not P.Has_Key (Right, Y) - then - return False; - end if; - - if P.Get (Left, X) /= P.Get (Right, Y) - or P.Get (Left, Y) /= P.Get (Right, X) - then - return False; - end if; - - for C of Left loop - if not P.Has_Key (Right, C) then - return False; - end if; - end loop; - - for C of Right loop - if not P.Has_Key (Left, C) - or else (C /= X - and C /= Y - and P.Get (Left, C) /= P.Get (Right, C)) - then - return False; - end if; - end loop; - - return True; - end P_Positions_Swapped; - - --------------------------- - -- P_Positions_Truncated -- - --------------------------- - - function P_Positions_Truncated - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - return False; - - elsif P.Has_Key (Small, Cu) then - return False; - end if; - end; - end loop; - - return True; - end P_Positions_Truncated; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : List) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.First; - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = To_Big_Integer (I)); - Position := Container.Nodes (Position).Next; - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (Container : in out List; X : Count_Type) is - pragma Assert (X > 0); - pragma Assert (X <= Container.Capacity); - - N : Node_Array renames Container.Nodes; - - begin - N (X).Prev := -1; -- Node is deallocated (not on active list) - - if Container.Free >= 0 then - N (X).Next := Container.Free; - Container.Free := X; - - elsif X + 1 = abs Container.Free then - N (X).Next := 0; -- Not strictly necessary, but marginally safer - Container.Free := Container.Free + 1; - - else - Container.Free := abs Container.Free; - - if Container.Free > Container.Capacity then - Container.Free := 0; - - else - for J in Container.Free .. Container.Capacity - 1 loop - N (J).Next := J + 1; - end loop; - - N (Container.Capacity).Next := 0; - end if; - - N (X).Next := Container.Free; - Container.Free := X; - end if; - end Free; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting with SPARK_Mode => Off is - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Elements_Sorted -- - ----------------------- - - function M_Elements_Sorted (Container : M.Sequence) return Boolean is - begin - if M.Length (Container) = 0 then - return True; - end if; - - declare - E1 : Element_Type := Element (Container, 1); - - begin - for I in 2 .. M.Length (Container) loop - declare - E2 : constant Element_Type := Element (Container, I); - - begin - if E2 < E1 then - return False; - end if; - - E1 := E2; - end; - end loop; - end; - - return True; - end M_Elements_Sorted; - - end Formal_Model; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : List) return Boolean is - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := Container.First; - - begin - for J in 2 .. Container.Length loop - if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then - return False; - else - Node := Nodes (Node).Next; - end if; - end loop; - - return True; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out List; Source : in out List) is - LN : Node_Array renames Target.Nodes; - RN : Node_Array renames Source.Nodes; - LI : Cursor; - RI : Cursor; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - LI := First (Target); - RI := First (Source); - while RI.Node /= 0 loop - pragma Assert - (RN (RI.Node).Next = 0 - or else not (RN (RN (RI.Node).Next).Element < - RN (RI.Node).Element)); - - if LI.Node = 0 then - Splice (Target, No_Element, Source); - return; - end if; - - pragma Assert - (LN (LI.Node).Next = 0 - or else not (LN (LN (LI.Node).Next).Element < - LN (LI.Node).Element)); - - if RN (RI.Node).Element < LN (LI.Node).Element then - declare - RJ : Cursor := RI; - pragma Warnings (Off, RJ); - begin - RI.Node := RN (RI.Node).Next; - Splice (Target, LI, Source, RJ); - end; - - else - LI.Node := LN (LI.Node).Next; - end if; - end loop; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out List) is - N : Node_Array renames Container.Nodes; - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - declare - package Descriptors is new List_Descriptors - (Node_Ref => Count_Type, Nil => 0); - use Descriptors; - - function Next (Idx : Count_Type) return Count_Type is - (N (Idx).Next); - procedure Set_Next (Idx : Count_Type; Next : Count_Type) - with Inline; - procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) - with Inline; - function "<" (L, R : Count_Type) return Boolean is - (N (L).Element < N (R).Element); - procedure Update_Container (List : List_Descriptor) with Inline; - - procedure Set_Next (Idx : Count_Type; Next : Count_Type) is - begin - N (Idx).Next := Next; - end Set_Next; - - procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is - begin - N (Idx).Prev := Prev; - end Set_Prev; - - procedure Update_Container (List : List_Descriptor) is - begin - Container.First := List.First; - Container.Last := List.Last; - Container.Length := List.Length; - end Update_Container; - - procedure Sort_List is new Doubly_Linked_List_Sort; - begin - Sort_List (List_Descriptor'(First => Container.First, - Last => Container.Last, - Length => Container.Length)); - end; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Sort; - - end Generic_Sorting; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : List; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - end if; - - return Container.Nodes (Position.Node).Prev /= -1; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type) - is - J : Count_Type; - - begin - if Before.Node /= 0 then - pragma Assert (Vet (Container, Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - - if Container.Length > Container.Capacity - Count then - raise Constraint_Error with "new length exceeds capacity"; - end if; - - Allocate (Container, New_Item, New_Node => J); - Insert_Internal (Container, Before.Node, New_Node => J); - Position := (Node => J); - - for Index in 2 .. Count loop - Allocate (Container, New_Item, New_Node => J); - Insert_Internal (Container, Before.Node, New_Node => J); - end loop; - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor) - is - begin - Insert - (Container => Container, - Before => Before, - New_Item => New_Item, - Position => Position, - Count => 1); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type) - is - Position : Cursor; - - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type) - is - Position : Cursor; - - begin - Insert (Container, Before, New_Item, Position, 1); - end Insert; - - --------------------- - -- Insert_Internal -- - --------------------- - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Length = 0 then - pragma Assert (Before = 0); - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - - Container.First := New_Node; - Container.Last := New_Node; - - N (Container.First).Prev := 0; - N (Container.Last).Next := 0; - - elsif Before = 0 then - pragma Assert (N (Container.Last).Next = 0); - - N (Container.Last).Next := New_Node; - N (New_Node).Prev := Container.Last; - - Container.Last := New_Node; - N (Container.Last).Next := 0; - - elsif Before = Container.First then - pragma Assert (N (Container.First).Prev = 0); - - N (Container.First).Prev := New_Node; - N (New_Node).Next := Container.First; - - Container.First := New_Node; - N (Container.First).Prev := 0; - - else - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - N (New_Node).Next := Before; - N (New_Node).Prev := N (Before).Prev; - - N (N (Before).Prev).Next := New_Node; - N (Before).Prev := New_Node; - end if; - - Container.Length := Container.Length + 1; - end Insert_Internal; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : List) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ---------- - -- Last -- - ---------- - - function Last (Container : List) return Cursor is - begin - if Container.Last = 0 then - return No_Element; - end if; - - return (Node => Container.Last); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : List) return Element_Type is - L : constant Count_Type := Container.Last; - - begin - if L = 0 then - raise Constraint_Error with "list is empty"; - else - return Container.Nodes (L).Element; - end if; - end Last_Element; - - ------------ - -- Length -- - ------------ - - function Length (Container : List) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out List; Source : in out List) is - N : Node_Array renames Source.Nodes; - X : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - while Source.Length > 1 loop - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last /= Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy first element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); -- optimize away??? - - -- Unlink first node of Source - - Source.First := N (X).Next; - N (Source.First).Prev := 0; - - Source.Length := Source.Length - 1; - - -- The representation invariants for Source have been restored. It is - -- now safe to free the unlinked node, without fear of corrupting the - -- active links of Source. - - -- Note that the algorithm we use here models similar algorithms used - -- in the unbounded form of the doubly-linked list container. In that - -- case, Free is an instantation of Unchecked_Deallocation, which can - -- fail (because PE will be raised if controlled Finalize fails), so - -- we must defer the call until the last step. Here in the bounded - -- form, Free merely links the node we have just "deallocated" onto a - -- list of inactive nodes, so technically Free cannot fail. However, - -- for consistency, we handle Free the same way here as we do for the - -- unbounded form, with the pessimistic assumption that it can fail. - - Free (Source, X); - end loop; - - if Source.Length = 1 then - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last = Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); - - -- Unlink node of Source - - Source.First := 0; - Source.Last := 0; - Source.Length := 0; - - -- Return the unlinked node to the free store - - Free (Source, X); - end if; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Container : List; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - function Next (Container : List; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Program_Error with "Position cursor has no element"; - end if; - - return (Node => Container.Nodes (Position.Node).Next); - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend (Container : in out List; New_Item : Element_Type) is - begin - Insert (Container, First (Container), New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, First (Container), New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Container : List; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - function Previous (Container : List; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Program_Error with "Position cursor has no element"; - end if; - - return (Node => Container.Nodes (Position.Node).Prev); - end Previous; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access List; - Position : Cursor) return not null access Element_Type - is - begin - if not Has_Element (Container.all, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return Container.Nodes (Position.Node).Element'Access; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - N : Node_Array renames Container.Nodes; - I : Count_Type := Container.First; - J : Count_Type := Container.Last; - - procedure Swap (L : Count_Type; R : Count_Type); - - ---------- - -- Swap -- - ---------- - - procedure Swap (L : Count_Type; R : Count_Type) is - LN : constant Count_Type := N (L).Next; - LP : constant Count_Type := N (L).Prev; - - RN : constant Count_Type := N (R).Next; - RP : constant Count_Type := N (R).Prev; - - begin - if LP /= 0 then - N (LP).Next := R; - end if; - - if RN /= 0 then - N (RN).Prev := L; - end if; - - N (L).Next := RN; - N (R).Prev := LP; - - if LN = R then - pragma Assert (RP = L); - - N (L).Prev := R; - N (R).Next := L; - - else - N (L).Prev := RP; - N (RP).Next := L; - - N (R).Next := LN; - N (LN).Prev := R; - end if; - end Swap; - - -- Start of processing for Reverse_Elements - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); - - J := N (J).Next; - exit when I = J; - - I := N (I).Prev; - exit when I = J; - - Swap (L => J, R => I); - - I := N (I).Next; - exit when I = J; - - J := N (J).Prev; - exit when I = J; - end loop; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - CFirst : Count_Type := Position.Node; - - begin - if CFirst = 0 then - CFirst := Container.Last; - end if; - - if Container.Length = 0 then - return No_Element; - - else - while CFirst /= 0 loop - if Container.Nodes (CFirst).Element = Item then - return (Node => CFirst); - else - CFirst := Container.Nodes (CFirst).Prev; - end if; - end loop; - - return No_Element; - end if; - end Reverse_Find; - - ------------ - -- Splice -- - ------------ - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - is - SN : Node_Array renames Source.Nodes; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Before.Node /= 0 then - pragma Assert (Vet (Target, Before), "bad cursor in Splice"); - end if; - - pragma Assert (SN (Source.First).Prev = 0); - pragma Assert (SN (Source.Last).Next = 0); - - if Target.Length > Count_Type'Base'Last - Source.Length then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - if Target.Length + Source.Length > Target.Capacity then - raise Constraint_Error; - end if; - - loop - Insert (Target, Before, SN (Source.Last).Element); - Delete_Last (Source); - exit when Is_Empty (Source); - end loop; - end Splice; - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - is - Target_Position : Cursor; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Source, Position), "bad Position cursor in Splice"); - - if Target.Length >= Target.Capacity then - raise Constraint_Error; - end if; - - Insert - (Container => Target, - Before => Before, - New_Item => Source.Nodes (Position.Node).Element, - Position => Target_Position); - - Delete (Source, Position); - Position := Target_Position; - end Splice; - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - is - N : Node_Array renames Container.Nodes; - - begin - if Before.Node /= 0 then - pragma Assert - (Vet (Container, Before), "bad Before cursor in Splice"); - end if; - - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad Position cursor in Splice"); - - if Position.Node = Before.Node - or else N (Position.Node).Next = Before.Node - then - return; - end if; - - pragma Assert (Container.Length >= 2); - - if Before.Node = 0 then - pragma Assert (Position.Node /= Container.Last); - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.Last).Next := Position.Node; - N (Position.Node).Prev := Container.Last; - - Container.Last := Position.Node; - N (Container.Last).Next := 0; - - return; - end if; - - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.First).Prev := Position.Node; - N (Position.Node).Next := Container.First; - - Container.First := Position.Node; - N (Container.First).Prev := 0; - - return; - end if; - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - elsif Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (N (Before.Node).Prev).Next := Position.Node; - N (Position.Node).Prev := N (Before.Node).Prev; - - N (Before.Node).Prev := Position.Node; - N (Position.Node).Next := Before.Node; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Splice; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out List; - I : Cursor; - J : Cursor) - is - begin - if I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Node = J.Node then - return; - end if; - - pragma Assert (Vet (Container, I), "bad I cursor in Swap"); - pragma Assert (Vet (Container, J), "bad J cursor in Swap"); - - declare - NN : Node_Array renames Container.Nodes; - NI : Node_Type renames NN (I.Node); - NJ : Node_Type renames NN (J.Node); - - EI_Copy : constant Element_Type := NI.Element; - - begin - NI.Element := NJ.Element; - NJ.Element := EI_Copy; - end; - end Swap; - - ---------------- - -- Swap_Links -- - ---------------- - - procedure Swap_Links - (Container : in out List; - I : Cursor; - J : Cursor) - is - I_Next : Cursor; - J_Next : Cursor; - - begin - if I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Node = J.Node then - return; - end if; - - pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); - pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); - - I_Next := Next (Container, I); - - if I_Next = J then - Splice (Container, Before => I, Position => J); - - else - J_Next := Next (Container, J); - - if J_Next = I then - Splice (Container, Before => J, Position => I); - - else - pragma Assert (Container.Length >= 3); - Splice (Container, Before => I_Next, Position => J); - Splice (Container, Before => J_Next, Position => I); - end if; - end if; - end Swap_Links; - - --------- - -- Vet -- - --------- - - function Vet (L : List; Position : Cursor) return Boolean is - N : Node_Array renames L.Nodes; - begin - if not Container_Checks'Enabled then - return True; - end if; - - if L.Length = 0 then - return False; - end if; - - if L.First = 0 then - return False; - end if; - - if L.Last = 0 then - return False; - end if; - - if Position.Node > L.Capacity then - return False; - end if; - - if N (Position.Node).Prev < 0 - or else N (Position.Node).Prev > L.Capacity - then - return False; - end if; - - if N (Position.Node).Next > L.Capacity then - return False; - end if; - - if N (L.First).Prev /= 0 then - return False; - end if; - - if N (L.Last).Next /= 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 and then Position.Node /= L.First then - return False; - end if; - - if N (Position.Node).Next = 0 and then Position.Node /= L.Last then - return False; - end if; - - if L.Length = 1 then - return L.First = L.Last; - end if; - - if L.First = L.Last then - return False; - end if; - - if N (L.First).Next = 0 then - return False; - end if; - - if N (L.Last).Prev = 0 then - return False; - end if; - - if N (N (L.First).Next).Prev /= L.First then - return False; - end if; - - if N (N (L.Last).Prev).Next /= L.Last then - return False; - end if; - - if L.Length = 2 then - if N (L.First).Next /= L.Last then - return False; - end if; - - if N (L.Last).Prev /= L.First then - return False; - end if; - - return True; - end if; - - if N (L.First).Next = L.Last then - return False; - end if; - - if N (L.Last).Prev = L.First then - return False; - end if; - - if Position.Node = L.First then - return True; - end if; - - if Position.Node = L.Last then - return True; - end if; - - if N (Position.Node).Next = 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 then - return False; - end if; - - if N (N (Position.Node).Next).Prev /= Position.Node then - return False; - end if; - - if N (N (Position.Node).Prev).Next /= Position.Node then - return False; - end if; - - if L.Length = 3 then - if N (L.First).Next /= Position.Node then - return False; - end if; - - if N (L.Last).Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end Vet; - -end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads index 01e7db2..3a53ca5 100644 --- a/gcc/ada/libgnat/a-cfdlli.ads +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -29,1643 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; - generic - type Element_Type is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Doubly_Linked_Lists with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - type List (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (List); - pragma Preelaborable_Initialization (List); - - type Cursor is record - Node : Count_Type := 0; - end record; - - No_Element : constant Cursor := Cursor'(Node => 0); - - Empty_List : constant List; - - function Length (Container : List) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Positive_Count_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in 1 .. M.Length (Container) => - (for some J in 1 .. M.Length (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in 1 .. M.Length (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Positive_Count_Type := 1; - L_Lst : Count_Type; - Right : M.Sequence; - R_Fst : Positive_Count_Type := 1; - R_Lst : Count_Type) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in 1 .. M.Length (Left) => - Element (Left, I) = - Element (Right, M.Length (Left) - I + 1)) - and (for all I in 1 .. M.Length (Left) => - Element (Right, I) = - Element (Left, M.Length (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Positive_Count_Type; - Y : Positive_Count_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Length (Left) and Y <= M.Length (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function P_Positions_Swapped - (Left : P.Map; - Right : P.Map; - X : Cursor; - Y : Cursor) return Boolean - -- Left and Right contain the same cursors, but the positions of X and Y - -- are reversed. - with - Ghost, - Global => null, - Post => - P_Positions_Swapped'Result = - (P.Same_Keys (Left, Right) - and P.Elements_Equal_Except (Left, Right, X, Y) - and P.Has_Key (Left, X) - and P.Has_Key (Left, Y) - and P.Get (Left, X) = P.Get (Right, Y) - and P.Get (Left, Y) = P.Get (Right, X)); - - function P_Positions_Truncated - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Ghost, - Global => null, - Post => - P_Positions_Truncated'Result = - - -- Big contains all cursors of Small at the same position - - (Small <= Big - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Mapping_Preserved - (M_Left : M.Sequence; - M_Right : M.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Left and Right contain the same cursors - - P.Same_Keys (P_Left, P_Right) - - -- Mappings from cursors to elements induced by M_Left, P_Left - -- and M_Right, P_Right are the same. - - and (for all C of P_Left => - M.Get (M_Left, P.Get (P_Left, C)) = - M.Get (M_Right, P.Get (P_Right, C)))); - - function Model (Container : List) return M.Sequence with - -- The high-level model of a list is a sequence of elements. Cursors are - -- not represented in this model. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); - - function Positions (Container : List) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and map them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length. - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : List) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access to the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level cursor-aware view of a container to a high-level - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Elt of Model (Container) => - (for some I of Positions (Container) => - M.Get (Model (Container), P.Get (Positions (Container), I)) = - Elt)); - - function Element - (S : M.Sequence; - I : Count_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : List) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Is_Empty (Container : List) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out List) with - Global => null, - Post => Length (Container) = 0; - - procedure Assign (Target : in out List; Source : List) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => Model (Target) = Model (Source); - - function Copy (Source : List; Capacity : Count_Type := 0) return List with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Element - (Container : List; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - Element (Model (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Cursors are preserved - - and Positions (Container)'Old = Positions (Container) - - -- The element at the position of Position in Container is New_Item - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- Other elements are preserved - - and M.Equal_Except - (Model (Container)'Old, - Model (Container), - P.Get (Positions (Container), Position)); - - function At_End (E : access constant List) return access constant List - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function At_End - (E : access constant Element_Type) return access constant Element_Type - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - Element (Model (Container), P.Get (Positions (Container), Position)); - - function Reference - (Container : not null access List; - Position : Cursor) return not null access Element_Type - with - Global => null, - Pre => Has_Element (Container.all, Position), - Post => - Length (Container.all) = Length (At_End (Container).all) - - -- Cursors are preserved - - and Positions (Container.all) = Positions (At_End (Container).all) - - -- Container will have Result.all at position Position - - and At_End (Reference'Result).all = - Element (Model (At_End (Container).all), - P.Get (Positions (At_End (Container).all), Position)) - - -- All other elements are preserved - - and M.Equal_Except - (Model (Container.all), - Model (At_End (Container).all), - P.Get (Positions (At_End (Container).all), Position)); - - procedure Move (Target : in out List; Source : in out List) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => Model (Target) = Model (Source'Old) and Length (Source) = 0; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + 1, - Contract_Cases => - (Before = No_Element => - - -- Positions contains a new mapping from the last cursor of - -- Container to its length. - - P.Get (Positions (Container), Last (Container)) = Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at the previous position of Before in - -- Container. - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = New_Item - - -- A new cursor has been inserted at position Before in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before))); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Container.Capacity - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Before = No_Element => - - -- The elements of Container are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Before - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => - P.Get (Positions (Container)'Old, Before) - 1 + Count, - Item => New_Item) - - -- Count cursors have been inserted at position Before in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before), - Count => Count)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - and P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = Length (Container) - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at Position in Container - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- A new cursor has been inserted at position Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Container.Capacity - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Count = 0 => - Position = Before - and Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - others => - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = - Length (Container)'Old + 1 - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Position - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => - P.Get (Positions (Container), Position) - 1 + Count, - Item => New_Item) - - -- Count cursor have been inserted at Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position), - Count => Count)); - - procedure Prepend (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Container.Capacity, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is the first element of Container - - and Element (Model (Container), 1) = New_Item - - -- A new cursor has been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1); - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Container.Capacity - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => Count) - - -- Container starts with Count times New_Item - - and M.Constant_Range - (Container => Model (Container), - Fst => 1, - Lst => Count, - Item => New_Item) - - -- Count cursors have been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1, - Count => Count); - - procedure Append (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Container.Capacity, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions contains a new mapping from the last cursor of Container - -- to its length. - - and P.Get (Positions (Container), Last (Container)) = - Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container); - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Container.Capacity - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count); - - procedure Delete (Container : in out List; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count < P.Get (Positions (Container), Position) => - Length (Container) = - P.Get (Positions (Container)'Old, Position'Old) - 1 - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => Count) - - -- Count cursors have been removed from Container at Position - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count)); - - procedure Delete_First (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- The first cursor of Container has been removed - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1); - - procedure Delete_First (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => Count) - - -- The first Count cursors have been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1, - Count => Count)); - - procedure Delete_Last (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- The last cursor of Container has been removed - - and not P.Has_Key (Positions (Container), Last (Container)'Old) - - -- Other cursors are still valid - - and P.Keys_Included_Except - (Left => Positions (Container)'Old, - Right => Positions (Container)'Old, - New_Key => Last (Container)'Old) - - -- The positions of other cursors are preserved - - and Positions (Container) <= Positions (Container)'Old; - - procedure Delete_Last (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => Length (Container) + 1, - Count => Count)); - - procedure Reverse_Elements (Container : in out List) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container)'Old, - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - - and Positions (Container) = Positions (Container)'Old; - - procedure Swap_Links - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container'Old), - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - and P_Positions_Swapped - (Positions (Container)'Old, Positions (Container), I, J); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - -- Target and Source should not be aliased - with - Global => null, - Pre => - Length (Source) <= Target.Capacity - Length (Target) - and then (Has_Element (Target, Before) - or else Before = No_Element), - Post => - Length (Source) = 0 - and Length (Target) = Length (Target)'Old + Length (Source)'Old, - Contract_Cases => - (Before = No_Element => - - -- The elements of Target are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => Length (Target)'Old) - - -- The elements of Source are appended to target, the order is not - -- specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => Length (Target)'Old + 1, - R_Lst => Length (Target)) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => Length (Target)'Old + 1, - L_Lst => Length (Target), - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Cursors have been inserted at the end of Target - - and P_Positions_Truncated - (Positions (Target)'Old, - Positions (Target), - Cut => Length (Target)'Old + 1, - Count => Length (Source)'Old), - - others => - - -- The elements of Target located before Before are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target)'Old, Before) - 1) - - -- The elements of Source are inserted before Before, the order is - -- not specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => P.Get (Positions (Target)'Old, Before), - R_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => P.Get (Positions (Target)'Old, Before), - L_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old, - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Other elements are shifted by the length of Source - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target)'Old, Before), - Lst => Length (Target)'Old, - Offset => Length (Source)'Old) - - -- Cursors have been inserted at position Before in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target)'Old, Before), - Count => Length (Source)'Old)); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - -- Target and Source should not be aliased - with - Global => null, - Pre => - (Has_Element (Target, Before) or else Before = No_Element) - and then Has_Element (Source, Position) - and then Length (Target) < Target.Capacity, - Post => - Length (Target) = Length (Target)'Old + 1 - and Length (Source) = Length (Source)'Old - 1 - - -- The elements of Source located before Position are preserved - - and M.Range_Equal - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => 1, - Lst => P.Get (Positions (Source)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => P.Get (Positions (Source)'Old, Position'Old) + 1, - Lst => Length (Source)'Old, - Offset => -1) - - -- Position has been removed from Source - - and P_Positions_Shifted - (Positions (Source), - Positions (Source)'Old, - Cut => P.Get (Positions (Source)'Old, Position'Old)) - - -- Positions is valid in Target and it is located either before - -- Before if it is valid in Target or at the end if it is No_Element. - - and P.Has_Key (Positions (Target), Position) - and (if Before = No_Element then - P.Get (Positions (Target), Position) = Length (Target) - else - P.Get (Positions (Target), Position) = - P.Get (Positions (Target)'Old, Before)) - - -- The elements of Target located before Position are preserved - - and M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target), Position), - Lst => Length (Target)'Old, - Offset => 1) - - -- The element located at Position in Source is moved to Target - - and Element (Model (Target), - P.Get (Positions (Target), Position)) = - Element (Model (Source)'Old, - P.Get (Positions (Source)'Old, Position'Old)) - - -- A new cursor has been inserted at position Position in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target), Position)); - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - with - Global => null, - Pre => - (Has_Element (Container, Before) or else Before = No_Element) - and then Has_Element (Container, Position), - Post => Length (Container) = Length (Container)'Old, - Contract_Cases => - (Before = Position => - Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - Before = No_Element => - - -- The elements located before Position are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => Length (Container)'Old, - Offset => -1) - - -- The last element of Container is the one that was previously at - -- Position. - - and Element (Model (Container), - Length (Container)) = - Element (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)), - - others => - - -- The elements located before Position and Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => - Count_Type'Min - (P.Get (Positions (Container)'Old, Position) - 1, - P.Get (Positions (Container)'Old, Before) - 1)) - - -- The elements located after Position and Before are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => - Count_Type'Max - (P.Get (Positions (Container)'Old, Position) + 1, - P.Get (Positions (Container)'Old, Before) + 1), - Lst => Length (Container)) - - -- The elements located after Before and before Position are - -- shifted by 1 to the right. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before) + 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1, - Offset => 1) - - -- The elements located after Position and before Before are - -- shifted by 1 to the left. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1, - Offset => -1) - - -- The element previously at Position is now before Before - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = - Element - (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container))); - - function First (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => First_Element'Result = M.Get (Model (Container), 1); - - function Last (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = M.Get (Model (Container), Length (Container)); - - function Next (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container after Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => Length (Container), - Item => Item) - => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Find'Result)) = Item - - -- The result of Find is located after Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Find'Result) >= - P.Get (Positions (Container), Position)) - - -- It is the first occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => - P.Get (Positions (Container), Find'Result) - 1, - Item => Item)); - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container before Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item) - => - Reverse_Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Reverse_Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Reverse_Find'Result)) = Item - - -- The result of Find is located before Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Reverse_Find'Result) <= - P.Get (Positions (Container), Position)) - - -- It is the last occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - P.Get (Positions (Container), - Reverse_Find'Result) + 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item)); - - function Contains - (Container : List; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = M.Contains (Container => Model (Container), - Fst => 1, - Lst => Length (Container), - Item => Item); - - function Has_Element - (Container : List; - Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in 1 .. M.Length (Container) => - (for all J in I .. M.Length (Container) => - not (Element (Container, J) < Element (Container, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : List) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out List) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Length (Container), - Right => Model (Container), - R_Lst => Length (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Length (Container), - Right => Model (Container)'Old, - R_Lst => Length (Container)); - - procedure Merge (Target : in out List; Source : in out List) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Target.Capacity - Length (Target), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Length (Target)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - type Node_Type is record - Prev : Count_Type'Base := -1; - Next : Count_Type; - Element : aliased Element_Type; - end record; - - function "=" (L, R : Node_Type) return Boolean is abstract; - - type Node_Array is array (Count_Type range <>) of Node_Type; - function "=" (L, R : Node_Array) return Boolean is abstract; - - type List (Capacity : Count_Type) is record - Free : Count_Type'Base := -1; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - Nodes : Node_Array (1 .. Capacity); - end record; +package Ada.Containers.Formal_Doubly_Linked_Lists with SPARK_Mode is - Empty_List : constant List := (0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb deleted file mode 100644 index bdf2c61..0000000 --- a/gcc/ada/libgnat/a-cfhama.adb +++ /dev/null @@ -1,976 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2022, 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Formal_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); - -with Ada.Containers.Hash_Tables.Generic_Formal_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys); - -with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; - -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Hashed_Maps with - SPARK_Mode => Off -is - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All local subprograms require comments ??? - - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - procedure Free - (HT : in out Map; - X : Count_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out HT_Types.Hash_Table_Type; - Node : out Count_Type); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Container : Map; Position : Cursor) return Boolean - with Inline; - - -- Convert Count_Type to Big_Interger - - package Conversions is new Signed_Conversions (Int => Count_Type); - - function Big (J : Count_Type) return Big_Integer renames - Conversions.To_Big_Integer; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is - new Hash_Tables.Generic_Formal_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Key_Ops is - new Hash_Tables.Generic_Formal_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Length (Left) = 0 then - return True; - end if; - - declare - Node : Count_Type; - ENode : Count_Type; - - begin - Node := First (Left).Node; - while Node /= 0 loop - ENode := - Find - (Container => Right, - Key => Left.Content.Nodes (Node).Key).Node; - - if ENode = 0 or else - Right.Content.Nodes (ENode).Element /= - Left.Content.Nodes (Node).Element - then - return False; - end if; - - Node := HT_Ops.Next (Left.Content, Node); - end loop; - - return True; - end; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Element (Source_Node : Count_Type); - pragma Inline (Insert_Element); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Content.Nodes (Source_Node); - begin - Insert (Target, N.Key, N.Element); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- correct exception ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - Insert_Elements (Source.Content); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Map) return Count_Type is - begin - return Container.Content.Nodes'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - HT_Ops.Clear (Container.Content); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return not null access constant Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), - "bad cursor in function Constant_Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - is - C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); - Cu : Cursor; - H : Hash_Type; - N : Count_Type; - Target : Map (C, Source.Modulus); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - Target.Content.Length := Source.Content.Length; - Target.Content.Free := Source.Content.Free; - - H := 1; - while H <= Source.Modulus loop - Target.Content.Buckets (H) := Source.Content.Buckets (H); - H := H + 1; - end loop; - - N := 1; - while N <= Source.Capacity loop - Target.Content.Nodes (N) := Source.Content.Nodes (N); - N := N + 1; - end loop; - - while N <= C loop - Cu := (Node => N); - Free (Target, Cu.Node); - N := N + 1; - end loop; - - return Target; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Count_Type; - - begin - Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete key not in map"; - end if; - - Free (Container, X); - end Delete; - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Delete has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node); - - Free (Container, Position.Node); - Position := No_Element; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element; - end Element; - - function Element (Container : Map; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Content.Nodes (Position.Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Node.Key); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Count_Type; - begin - Key_Ops.Delete_Key_Sans_Free (Container.Content, Key, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container.Content); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end First; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------- - -- Find -- - ---------- - - function Find - (Container : K.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. K.Length (Container) loop - if Equivalent_Keys (Key, K.Get (Container, I)) then - return I; - end if; - end loop; - return 0; - end Find; - - --------------------- - -- K_Keys_Included -- - --------------------- - - function K_Keys_Included - (Left : K.Sequence; - Right : K.Sequence) return Boolean - is - begin - for I in 1 .. K.Length (Left) loop - if not K.Contains (Right, 1, K.Length (Right), K.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end K_Keys_Included; - - ---------- - -- Keys -- - ---------- - - function Keys (Container : Map) return K.Sequence is - Position : Count_Type := HT_Ops.First (Container.Content); - R : K.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := K.Add (R, Container.Content.Nodes (Position).Key); - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Keys; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Map) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (K_Left : K.Sequence; - K_Right : K.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > K.Length (K_Left) - or else P.Get (P_Right, C) > K.Length (K_Right) - or else K.Get (K_Left, P.Get (P_Left, C)) /= - K.Get (K_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ----------- - -- Model -- - ----------- - - function Model (Container : Map) return M.Map is - Position : Count_Type := HT_Ops.First (Container.Content); - R : M.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - New_Key => Container.Content.Nodes (Position).Key, - New_Item => Container.Content.Nodes (Position).Element); - - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Map) return P.Map is - I : Count_Type := 1; - Position : Count_Type := HT_Ops.First (Container.Content); - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = Big (I)); - Position := HT_Ops.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (HT : in out Map; X : Count_Type) is - begin - if X /= 0 then - pragma Assert (X <= HT.Capacity); - HT.Content.Nodes (X).Has_Element := False; - HT_Ops.Free (HT.Content, X); - end if; - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (HT : in out HT_Types.Hash_Table_Type; - Node : out Count_Type) - is - procedure Allocate is - new HT_Ops.Generic_Allocate (Set_Element); - - begin - Allocate (HT, Node); - HT.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Map; Position : Cursor) return Boolean is - begin - if Position.Node = 0 - or else not Container.Content.Nodes (Position.Node).Has_Element - then - return False; - else - return True; - end if; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Key); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - declare - P : constant Count_Type := Position.Node; - N : Node_Type renames Container.Content.Nodes (P); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); - - procedure New_Node - (HT : in out HT_Types.Hash_Table_Type; - Node : out Count_Type); - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Assign_Key); - - ----------------- - -- Assign_Key -- - ----------------- - - procedure Assign_Key (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Assign_Key; - - -------------- - -- New_Node -- - -------------- - - procedure New_Node - (HT : in out HT_Types.Hash_Table_Type; - Node : out Count_Type) - is - begin - Allocate (HT, Node); - end New_Node; - - -- Start of processing for Insert - - begin - Local_Insert (Container.Content, Key, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Unused_Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Unused_Position, Inserted); - - if not Inserted then - raise Constraint_Error with "attempt to insert key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - --------- - -- Key -- - --------- - - function Key (Container : Map; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Key has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in function Key"); - - return Container.Content.Nodes (Position.Node).Key; - end Key; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Map; - Source : in out Map) - is - NN : HT_Types.Nodes_Type renames Source.Content.Nodes; - X : Count_Type; - Y : Count_Type; - - begin - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - if Source.Content.Length = 0 then - return; - end if; - - X := HT_Ops.First (Source.Content); - while X /= 0 loop - Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - - Y := HT_Ops.Next (Source.Content, X); - - HT_Ops.Delete_Node_Sans_Free (Source.Content, X); - Free (Source, X); - - X := Y; - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Container : Map; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in function Next"); - - declare - Node : constant Count_Type := - HT_Ops.Next (Container.Content, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Next; - - procedure Next (Container : Map; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access Map; - Position : Cursor) return not null access Element_Type - is - begin - if not Has_Element (Container.all, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container.all, Position), "bad cursor in function Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Reference; - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - is - Node : constant Count_Type := Find (Container.all, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace key not in map"; - end if; - - declare - N : Node_Type renames Container.Content.Nodes (Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Replace_Element has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Container.Content.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - is - begin - if Capacity > Container.Capacity then - raise Capacity_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - --------- - -- Vet -- - --------- - - function Vet (Container : Map; Position : Cursor) return Boolean is - begin - if not Container_Checks'Enabled then - return True; - end if; - - if Position.Node = 0 then - return True; - end if; - - declare - X : Count_Type; - - begin - if Container.Content.Length = 0 then - return False; - end if; - - if Container.Capacity = 0 then - return False; - end if; - - if Container.Content.Buckets'Length = 0 then - return False; - end if; - - if Position.Node > Container.Capacity then - return False; - end if; - - if Container.Content.Nodes (Position.Node).Next = Position.Node then - return False; - end if; - - X := - Container.Content.Buckets - (Key_Ops.Index - (Container.Content, - Container.Content.Nodes (Position.Node).Key)); - - for J in 1 .. Container.Content.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = Container.Content.Nodes (X).Next then - - -- Prevent unnecessary looping - - return False; - end if; - - X := Container.Content.Nodes (X).Next; - end loop; - - return False; - end; - end Vet; - -end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads index 8cb7488..42c7fbd 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -29,885 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Hashed_Maps in the --- Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- contents of a container: Key, Element, Next, Query_Element, Has_Element, --- Iterate, Equivalent_Keys. This change is motivated by the need to have --- cursors which are valid on different containers (typically a container C --- and its previous version C'Old) for expressing properties, which is not --- possible if cursors encapsulate an access to the underlying container. - --- Iteration over maps is done using the Iterable aspect, which is SPARK --- compatible. "For of" iteration ranges over keys instead of elements. - -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; -private with Ada.Containers.Hash_Tables; - generic - type Key_Type is private; - type Element_Type is private; - - with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys - (Left : Key_Type; - Right : Key_Type) return Boolean is "="; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Hashed_Maps with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Key), - Default_Initial_Condition => Is_Empty (Map); - pragma Preelaborable_Initialization (Map); - - Empty_Map : constant Map; - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Map) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Maps - (Element_Type => Element_Type, - Key_Type => Key_Type, - Equivalent_Keys => Equivalent_Keys); - - function "=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."="; - - function "<=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."<="; - - package K is new Ada.Containers.Functional_Vectors - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."="; - - function "<" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<"; - - function "<=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<="; - - function Find (Container : K.Sequence; Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= K.Length (Container) - and Equivalent_Keys (Key, K.Get (Container, Find'Result))); - - function K_Keys_Included - (Left : K.Sequence; - Right : K.Sequence) return Boolean - -- Return True if Right contains all the keys of Left - - with - Global => null, - Post => - K_Keys_Included'Result = - (for all I in 1 .. K.Length (Left) => - Find (Right, K.Get (Left, I)) > 0 - and then K.Get (Right, Find (Right, K.Get (Left, I))) = - K.Get (Left, I)); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function Mapping_Preserved - (K_Left : K.Sequence; - K_Right : K.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the keys of Left - - and K_Keys_Included (K_Left, K_Right) - - -- Mappings from cursors to elements induced by K_Left, P_Left - -- and K_Right, P_Right are the same. - - and (for all C of P_Left => - K.Get (K_Left, P.Get (P_Left, C)) = - K.Get (K_Right, P.Get (P_Right, C)))); - - function Model (Container : Map) return M.Map with - -- The high-level model of a map is a map from keys to elements. Neither - -- cursors nor order of elements are represented in this model. Keys are - -- modeled up to equivalence. - - Ghost, - Global => null; - - function Keys (Container : Map) return K.Sequence with - -- The Keys sequence represents the underlying list structure of maps - -- that is used for iteration. It stores the actual values of keys in - -- the map. It does not model cursors nor elements. - - Ghost, - Global => null, - Post => - K.Length (Keys'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Key of Keys'Result => - M.Has_Key (Model (Container), Key)) - - -- It contains all the keys contained in Model - - and (for all Key of Model (Container) => - (Find (Keys'Result, Key) > 0 - and then Equivalent_Keys - (K.Get (Keys'Result, Find (Keys'Result, Key)), - Key))) - - -- It has no duplicate - - and (for all I in 1 .. Length (Container) => - Find (Keys'Result, K.Get (Keys'Result, I)) = I) - - and (for all I in 1 .. Length (Container) => - (for all J in 1 .. Length (Container) => - (if Equivalent_Keys - (K.Get (Keys'Result, I), K.Get (Keys'Result, J)) - then - I = J))); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); - - function Positions (Container : Map) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Map) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Key of Keys (Container) => - (for some I of Positions (Container) => - K.Get (Keys (Container), P.Get (Positions (Container), I)) = - Key)); - - function Contains - (C : M.Map; - K : Key_Type) return Boolean renames M.Has_Key; - -- To improve readability of contracts, we rename the function used to - -- search for a key in the model to Contains. - - function Element - (C : M.Map; - K : Key_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : Map) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Capacity (Container : Map) return Count_Type with - Global => null, - Post => Capacity'Result = Container.Capacity; - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => - Model (Container) = Model (Container)'Old - and Length (Container)'Old = Length (Container) - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Container), Keys (Container)'Old) - and K_Keys_Included (Keys (Container)'Old, Keys (Container)); - - function Is_Empty (Container : Map) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Map) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Map; Source : Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Length (Source) = Length (Target) - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Target), Keys (Source)) - and K_Keys_Included (Keys (Source), Keys (Target)); - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Keys (Copy'Result) = Keys (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - -- Copy returns a container stricty equal to Source. It must have the same - -- cursors associated with each element. Therefore: - -- - capacity=0 means use Source.Capacity as capacity of target - -- - the modulus cannot be changed. - - function Key (Container : Map; Position : Cursor) return Key_Type with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Key'Result = - K.Get (Keys (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element - (Container : Map; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = Element (Model (Container), Key (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old - - -- New_Item is now associated with the key at position Position in - -- Container. - - and Element (Container, Position) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key (Container, Position)); - - function At_End - (E : not null access constant Map) return not null access constant Map - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function At_End - (E : access constant Element_Type) return access constant Element_Type - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - Element (Model (Container), Key (Container, Position)); - - function Reference - (Container : not null access Map; - Position : Cursor) return not null access Element_Type - with - Global => null, - Pre => Has_Element (Container.all, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with the key at position Position in Container. - - and Element (At_End (Container).all, Position) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key (At_End (Container).all, Position)); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Constant_Reference'Result.all = Element (Model (Container), Key); - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - with - Global => null, - Pre => Contains (Container.all, Key), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with Key in Container. - - and Element (Model (At_End (Container).all), Key) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key); - - procedure Move (Target : in out Map; Source : in out Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0 - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Target), Keys (Source)'Old) - and K_Keys_Included (Keys (Source)'Old, Keys (Target)); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) - and Has_Element (Container, Position) - and Equivalent_Keys - (Formal_Hashed_Maps.Key (Container, Position), Key), - Contract_Cases => - - -- If Key is already in Container, it is not modified and Inserted is - -- set to False. - - (Contains (Container, Key) => - not Inserted - and Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is inserted in Container and Inserted is set to True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Key now maps to New_Item - - and Formal_Hashed_Maps.Key (Container, Position) = Key - and Element (Model (Container), Key) = New_Item - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Position)); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, Key)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, Key) - - -- Key now maps to New_Item - - and Formal_Hashed_Maps.Key (Container, Find (Container, Key)) = Key - and Element (Model (Container), Key) = New_Item - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, Key)); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) and Element (Container, Key) = New_Item, - Contract_Cases => - - -- If Key is already in Container, Key is mapped to New_Item - - (Contains (Container, Key) => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key), - - -- Otherwise, Key is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Key is inserted in Container - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, Key))); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) - - -- New_Item is now associated with the Key in Container - - and Element (Model (Container), Key) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key); - - procedure Exclude (Container : in out Map; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old)); - - procedure Delete (Container : in out Map; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old); - - procedure Delete (Container : in out Map; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The key at position Position is no longer in Container - - and not Contains (Container, Key (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key (Container, Position)'Old) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Position'Old); - - function First (Container : Map) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function Next (Container : Map; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : Map; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Find (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Key) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Keys (Container), Key) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Formal_Hashed_Maps.Key (Container, Find'Result), Key)); - - function Contains (Container : Map; Key : Key_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Element (Container : Map; Key : Key_Type) return Element_Type with - Global => null, - Pre => Contains (Container, Key), - Post => Element'Result = Element (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - function Has_Element (Container : Map; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - function Default_Modulus (Capacity : Count_Type) return Hash_Type with - Global => null; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Length); - pragma Inline (Is_Empty); - pragma Inline (Clear); - pragma Inline (Key); - pragma Inline (Element); - pragma Inline (Contains); - pragma Inline (Capacity); - pragma Inline (Has_Element); - pragma Inline (Equivalent_Keys); - pragma Inline (Next); - - type Node_Type is record - Key : Key_Type; - Element : aliased Element_Type; - Next : Count_Type; - Has_Element : Boolean := False; - end record; - - package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type); - - type Map (Capacity : Count_Type; Modulus : Hash_Type) is record - Content : HT_Types.Hash_Table_Type (Capacity, Modulus); - end record; +package Ada.Containers.Formal_Hashed_Maps with SPARK_Mode is - Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb deleted file mode 100644 index 34afa55..0000000 --- a/gcc/ada/libgnat/a-cfhase.adb +++ /dev/null @@ -1,1559 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2022, 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Formal_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Operations); - -with Ada.Containers.Hash_Tables.Generic_Formal_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Formal_Keys); - -with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode => Off -is - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All need comments ??? - - procedure Difference (Left : Set; Right : Set; Target : in out Set); - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - procedure Free - (HT : in out Set; - X : Count_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out Hash_Table_Type; - Node : out Count_Type); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Intersection - (Left : Set; - Right : Set; - Target : in out Set); - - function Is_In - (HT : Set; - Key : Node_Type) return Boolean; - pragma Inline (Is_In); - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type); - pragma Inline (Set_Element); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Container : Set; Position : Cursor) return Boolean - with Inline; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Hash_Tables.Generic_Formal_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Element_Keys is new Hash_Tables.Generic_Formal_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - procedure Replace_Element is - new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Length (Left) = 0 then - return True; - end if; - - declare - Node : Count_Type; - ENode : Count_Type; - - begin - Node := First (Left).Node; - while Node /= 0 loop - ENode := - Find - (Container => Right, - Item => Left.Content.Nodes (Node).Element).Node; - - if ENode = 0 - or else Right.Content.Nodes (ENode).Element /= - Left.Content.Nodes (Node).Element - then - return False; - end if; - - Node := HT_Ops.Next (Left.Content, Node); - end loop; - - return True; - end; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - procedure Insert_Element (Source_Node : Count_Type); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Content.Nodes (Source_Node); - Unused_X : Count_Type; - B : Boolean; - - begin - Insert (Target, N.Element, Unused_X, B); - pragma Assert (B); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target.Capacity < Length (Source) then - raise Storage_Error with "not enough capacity"; -- SE or CE? ??? - end if; - - HT_Ops.Clear (Target.Content); - Insert_Elements (Source.Content); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Set) return Count_Type is - begin - return Container.Content.Nodes'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - HT_Ops.Clear (Container.Content); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - is - C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); - Cu : Cursor; - H : Hash_Type; - N : Count_Type; - Target : Set (C, Source.Modulus); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - Target.Content.Length := Source.Content.Length; - Target.Content.Free := Source.Content.Free; - - H := 1; - while H <= Source.Modulus loop - Target.Content.Buckets (H) := Source.Content.Buckets (H); - H := H + 1; - end loop; - - N := 1; - while N <= Source.Capacity loop - Target.Content.Nodes (N) := Source.Content.Nodes (N); - N := N + 1; - end loop; - - while N <= C loop - Cu := (Node => N); - Free (Target, Cu.Node); - N := N + 1; - end loop; - - return Target; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : Count_Type; - - begin - Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Free (Container, X); - end Delete; - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.Content, Position.Node); - Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - Src_Last : Count_Type; - Src_Length : Count_Type; - Src_Node : Count_Type; - Tgt_Node : Count_Type; - - TN : Nodes_Type renames Target.Content.Nodes; - SN : Nodes_Type renames Source.Content.Nodes; - - begin - Src_Length := Source.Content.Length; - - if Src_Length = 0 then - return; - end if; - - if Src_Length >= Target.Content.Length then - Tgt_Node := HT_Ops.First (Target.Content); - while Tgt_Node /= 0 loop - if Element_Keys.Find (Source.Content, TN (Tgt_Node).Element) /= 0 - then - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.Content, X); - Free (Target, X); - end; - - else - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - end if; - end loop; - - return; - else - Src_Node := HT_Ops.First (Source.Content); - Src_Last := 0; - end if; - - while Src_Node /= Src_Last loop - Tgt_Node := Element_Keys.Find (Target.Content, SN (Src_Node).Element); - - if Tgt_Node /= 0 then - HT_Ops.Delete_Node_Sans_Free (Target.Content, Tgt_Node); - Free (Target, Tgt_Node); - end if; - - Src_Node := HT_Ops.Next (Source.Content, Src_Node); - end loop; - end Difference; - - procedure Difference (Left : Set; Right : Set; Target : in out Set) is - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - B : Boolean; - E : Element_Type renames Left.Content.Nodes (L_Node).Element; - Unused_X : Count_Type; - - begin - if Find (Right, E).Node = 0 then - Insert (Target, E, Unused_X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Difference - - begin - Iterate (Left.Content); - end Difference; - - function Difference (Left : Set; Right : Set) return Set is - begin - if Length (Left) = 0 then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - declare - C : constant Count_Type := Length (Left); - H : constant Hash_Type := Default_Modulus (C); - begin - return S : Set (C, H) do - Difference (Left, Right, Target => S); - end return; - end; - end Difference; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Position : Cursor) return Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Content.Nodes (Position.Node).Element; - end Element; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equivalent_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - R_Node : Count_Type := R_HT.Buckets (R_Index); - RN : Nodes_Type renames R_HT.Nodes; - - begin - loop - if R_Node = 0 then - return False; - end if; - - if Equivalent_Elements - (L_Node.Element, RN (R_Node).Element) - then - return True; - end if; - - R_Node := HT_Ops.Next (R_HT, R_Node); - end loop; - end Find_Equivalent_Key; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Content, Right.Content); - end Equivalent_Sets; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Elements (Key, Node.Element); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : Count_Type; - begin - Element_Keys.Delete_Key_Sans_Free (Container.Content, Item, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Item : Element_Type) return Cursor - is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container.Content); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end First; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Elements_Included -- - ------------------------- - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - declare - Item : constant Element_Type := E.Get (Left, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Container) loop - declare - Item : constant Element_Type := E.Get (Container, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Left, 1, E.Length (Left), Item) then - return False; - end if; - else - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Elements (Item, E.Get (Container, I)) then - return I; - end if; - end loop; - return 0; - end Find; - - -------------- - -- Elements -- - -------------- - - function Elements (Container : Set) return E.Sequence is - Position : Count_Type := HT_Ops.First (Container.Content); - R : E.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := E.Add (R, Container.Content.Nodes (Position).Element); - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Elements; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Set) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------------ - -- Mapping_Preserved_Except -- - ------------------------------ - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - is - begin - for C of P_Left loop - if C /= Position - and (not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C))) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved_Except; - - ----------- - -- Model -- - ----------- - - function Model (Container : Set) return M.Set is - Position : Count_Type := HT_Ops.First (Container.Content); - R : M.Set; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - Item => Container.Content.Nodes (Position).Element); - - Position := HT_Ops.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Set) return P.Map is - I : Count_Type := 1; - Position : Count_Type := HT_Ops.First (Container.Content); - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = Big (I)); - Position := HT_Ops.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (HT : in out Set; X : Count_Type) is - begin - if X /= 0 then - pragma Assert (X <= HT.Capacity); - HT.Content.Nodes (X).Has_Element := False; - HT_Ops.Free (HT.Content, X); - end if; - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (HT : in out Hash_Table_Type; - Node : out Count_Type) - is - procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); - begin - Allocate (HT, Node); - HT.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - package body Generic_Keys with SPARK_Mode => Off is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is new Hash_Tables.Generic_Formal_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Key : Key_Type) return Boolean - is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : Count_Type; - - begin - Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - return Container.Content.Nodes (Node).Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); - end Equivalent_Key_Node; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : Count_Type; - begin - Key_Keys.Delete_Key_Sans_Free (Container.Content, Key, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Key : Key_Type) return Cursor - is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Find; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Included_Except -- - ----------------------- - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - is - begin - for E of Left loop - if not Contains (Right, E) - and not Equivalent_Keys (Generic_Keys.Key (E), Key) - then - return False; - end if; - end loop; - - return True; - end M_Included_Except; - - end Formal_Model; - - --------- - -- Key -- - --------- - - function Key (Container : Set; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Key"); - - declare - N : Node_Type renames Container.Content.Nodes (Position.Node); - begin - return Key (N.Element); - end; - end Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace key not in set"; - end if; - - Replace_Element (Container.Content, Node, New_Item); - end Replace; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Set; Position : Cursor) return Boolean is - begin - if Position.Node = 0 - or else not Container.Content.Nodes (Position.Node).Has_Element - then - return False; - end if; - - return True; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Element); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Inserted : Boolean; - Position : Cursor; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - Container.Content.Nodes (Position.Node).Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert (Container, New_Item, Position.Node, Inserted); - end Insert; - - procedure Insert (Container : in out Set; New_Item : Element_Type) is - Inserted : Boolean; - Unused_Position : Cursor; - - begin - Insert (Container, New_Item, Unused_Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Allocate_Set_Element (Node : in out Node_Type); - pragma Inline (Allocate_Set_Element); - - procedure New_Node - (HT : in out Hash_Table_Type; - Node : out Count_Type); - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Allocate_Set_Element); - - --------------------------- - -- Allocate_Set_Element -- - --------------------------- - - procedure Allocate_Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Allocate_Set_Element; - - -------------- - -- New_Node -- - -------------- - - procedure New_Node - (HT : in out Hash_Table_Type; - Node : out Count_Type) - is - begin - Allocate (HT, Node); - end New_Node; - - -- Start of processing for Insert - - begin - Local_Insert (Container.Content, New_Item, Node, Inserted); - end Insert; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - Tgt_Node : Count_Type; - TN : Nodes_Type renames Target.Content.Nodes; - - begin - if Source.Content.Length = 0 then - Clear (Target); - return; - end if; - - Tgt_Node := HT_Ops.First (Target.Content); - while Tgt_Node /= 0 loop - if Find (Source, TN (Tgt_Node).Element).Node /= 0 then - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - - else - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.Content, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.Content, X); - Free (Target, X); - end; - end if; - end loop; - end Intersection; - - procedure Intersection (Left : Set; Right : Set; Target : in out Set) is - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - E : Element_Type renames Left.Content.Nodes (L_Node).Element; - Unused_X : Count_Type; - B : Boolean; - - begin - if Find (Right, E).Node /= 0 then - Insert (Target, E, Unused_X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Intersection - - begin - Iterate (Left.Content); - end Intersection; - - function Intersection (Left : Set; Right : Set) return Set is - C : constant Count_Type := - Count_Type'Min (Length (Left), Length (Right)); -- ??? - H : constant Hash_Type := Default_Modulus (C); - - begin - return S : Set (C, H) do - if Length (Left) /= 0 and Length (Right) /= 0 then - Intersection (Left, Right, Target => S); - end if; - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ----------- - -- Is_In -- - ----------- - - function Is_In (HT : Set; Key : Node_Type) return Boolean is - begin - return Element_Keys.Find (HT.Content, Key.Element) /= 0; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - Subset_Node : Count_Type; - Subset_Nodes : Nodes_Type renames Subset.Content.Nodes; - - begin - if Length (Subset) > Length (Of_Set) then - return False; - end if; - - Subset_Node := First (Subset).Node; - while Subset_Node /= 0 loop - declare - S : constant Count_Type := Subset_Node; - N : Node_Type renames Subset_Nodes (S); - E : Element_Type renames N.Element; - - begin - if Find (Of_Set, E).Node = 0 then - return False; - end if; - end; - - Subset_Node := HT_Ops.Next (Subset.Content, Subset_Node); - end loop; - - return True; - end Is_Subset; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - -- Comments??? - - procedure Move (Target : in out Set; Source : in out Set) is - NN : HT_Types.Nodes_Type renames Source.Content.Nodes; - X, Y : Count_Type; - - begin - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - if Source.Content.Length = 0 then - return; - end if; - - X := HT_Ops.First (Source.Content); - while X /= 0 loop - Insert (Target, NN (X).Element); -- optimize??? - - Y := HT_Ops.Next (Source.Content, X); - - HT_Ops.Delete_Node_Sans_Free (Source.Content, X); - Free (Source, X); - - X := Y; - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Container : Set; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Next"); - - return (Node => HT_Ops.Next (Container.Content, Position.Node)); - end Next; - - procedure Next (Container : Set; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - Left_Node : Count_Type; - Left_Nodes : Nodes_Type renames Left.Content.Nodes; - - begin - if Length (Right) = 0 or Length (Left) = 0 then - return False; - end if; - - Left_Node := First (Left).Node; - while Left_Node /= 0 loop - declare - L : constant Count_Type := Left_Node; - N : Node_Type renames Left_Nodes (L); - E : Element_Type renames N.Element; - begin - if Find (Right, E).Node /= 0 then - return True; - end if; - end; - - Left_Node := HT_Ops.Next (Left.Content, Left_Node); - end loop; - - return False; - end Overlap; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, New_Item); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace element not in set"; - end if; - - Container.Content.Nodes (Node).Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Replace_Element (Container.Content, Position.Node, New_Item); - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - is - begin - if Capacity > Container.Capacity then - raise Constraint_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - ------------------ - -- Set_Element -- - ------------------ - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is - begin - Node.Element := Item; - end Set_Element; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - procedure Process (Source_Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Source_Node : Count_Type) is - B : Boolean; - N : Node_Type renames Source.Content.Nodes (Source_Node); - Unused_X : Count_Type; - - begin - if Is_In (Target, N) then - Delete (Target, N.Element); - else - Insert (Target, N.Element, Unused_X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Symmetric_Difference - - begin - if Length (Target) = 0 then - Assign (Target, Source); - return; - end if; - - Iterate (Source.Content); - end Symmetric_Difference; - - function Symmetric_Difference (Left : Set; Right : Set) return Set is - begin - if Length (Right) = 0 then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - declare - C : constant Count_Type := Length (Left) + Length (Right); - H : constant Hash_Type := Default_Modulus (C); - begin - return S : Set (C, H) do - Difference (Left, Right, S); - Difference (Right, Left, S); - end return; - end; - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Unused_X : Count_Type; - B : Boolean; - - begin - return S : Set (Capacity => 1, Modulus => 1) do - Insert (S, New_Item, Unused_X, B); - pragma Assert (B); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - procedure Process (Src_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Count_Type) is - N : Node_Type renames Source.Content.Nodes (Src_Node); - E : Element_Type renames N.Element; - - Unused_X : Count_Type; - Unused_B : Boolean; - - begin - Insert (Target, E, Unused_X, Unused_B); - end Process; - - -- Start of processing for Union - - begin - Iterate (Source.Content); - end Union; - - function Union (Left : Set; Right : Set) return Set is - begin - if Length (Right) = 0 then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - declare - C : constant Count_Type := Length (Left) + Length (Right); - H : constant Hash_Type := Default_Modulus (C); - begin - return S : Set (C, H) do - Assign (Target => S, Source => Left); - Union (Target => S, Source => Right); - end return; - end; - end Union; - - --------- - -- Vet -- - --------- - - function Vet (Container : Set; Position : Cursor) return Boolean is - begin - if not Container_Checks'Enabled then - return True; - end if; - - if Position.Node = 0 then - return True; - end if; - - declare - S : Set renames Container; - N : Nodes_Type renames S.Content.Nodes; - X : Count_Type; - - begin - if S.Content.Length = 0 then - return False; - end if; - - if Position.Node > N'Last then - return False; - end if; - - if N (Position.Node).Next = Position.Node then - return False; - end if; - - X := S.Content.Buckets - (Element_Keys.Index (S.Content, N (Position.Node).Element)); - - for J in 1 .. S.Content.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = N (X).Next then -- to prevent unnecessary looping - return False; - end if; - - X := N (X).Next; - end loop; - - return False; - end; - end Vet; - -end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads index 248a0ac..633ed20 100644 --- a/gcc/ada/libgnat/a-cfhase.ads +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -29,1475 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Hashed_Sets in the --- Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Element, Next, Query_Element, Has_Element, Key, --- Iterate, Equivalent_Elements. This change is motivated by the need to --- have cursors which are valid on different containers (typically a --- container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. - -with Ada.Containers.Functional_Maps; -with Ada.Containers.Functional_Sets; -with Ada.Containers.Functional_Vectors; -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; -private with Ada.Containers.Hash_Tables; - generic - type Element_Type is private; - - with function Hash (Element : Element_Type) return Hash_Type; - - with function Equivalent_Elements - (Left : Element_Type; - Right : Element_Type) return Boolean is "="; - -package Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - -- Convert Count_Type to Big_Interger. - - package Conversions is new Signed_Conversions (Int => Count_Type); - - function Big (J : Count_Type) return Big_Integer renames - Conversions.To_Big_Integer; - - type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (Set); - pragma Preelaborable_Initialization (Set); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Set) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Sets - (Element_Type => Element_Type, - Equivalent_Elements => Equivalent_Elements); - - function "=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."="; - - function "<=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."<="; - - package E is new Ada.Containers.Functional_Vectors - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."="; - - function "<" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<"; - - function "<=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<="; - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - -- Search for Item in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Elements - (Item, E.Get (Container, Find'Result))); - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Left are contained in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - (if M.Contains (Model, E.Get (Left, I)) then - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Left and others - -- are in Right. - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Container) => - (if M.Contains (Model, E.Get (Container, I)) then - Find (Left, E.Get (Container, I)) > 0 - and then E.Get (Left, Find (Left, E.Get (Container, I))) = - E.Get (Container, I) - else - Find (Right, E.Get (Container, I)) > 0 - and then E.Get - (Right, Find (Right, E.Get (Container, I))) = - E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the elements of Left - - and E_Elements_Included (E_Left, E_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same. - - and (for all C of P_Left => - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C)))); - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved_Except'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same except for Position. - - and (for all C of P_Left => - (if C /= Position then - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C))))); - - function Model (Container : Set) return M.Set with - -- The high-level model of a set is a set of elements. Neither cursors - -- nor order of elements are represented in this model. Elements are - -- modeled up to equivalence. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Big (Length (Container)); - - function Elements (Container : Set) return E.Sequence with - -- The Elements sequence represents the underlying list structure of - -- sets that is used for iteration. It stores the actual values of - -- elements in the set. It does not model cursors. - - Ghost, - Global => null, - Post => - E.Length (Elements'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Item of Elements'Result => - M.Contains (Model (Container), Item)) - - -- It contains all the elements contained in Model - - and (for all Item of Model (Container) => - (Find (Elements'Result, Item) > 0 - and then Equivalent_Elements - (E.Get (Elements'Result, - Find (Elements'Result, Item)), - Item))) - - -- It has no duplicate - - and (for all I in 1 .. Length (Container) => - Find (Elements'Result, E.Get (Elements'Result, I)) = I) - - and (for all I in 1 .. Length (Container) => - (for all J in 1 .. Length (Container) => - (if Equivalent_Elements - (E.Get (Elements'Result, I), - E.Get (Elements'Result, J)) - then I = J))); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); - - function Positions (Container : Set) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Set) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Item of Elements (Container) => - (for some I of Positions (Container) => - E.Get (Elements (Container), P.Get (Positions (Container), I)) = - Item)); - - function Contains - (C : M.Set; - K : Element_Type) return Boolean renames M.Contains; - -- To improve readability of contracts, we rename the function used to - -- search for an element in the model to Contains. - - end Formal_Model; - use Formal_Model; - - Empty_Set : constant Set; - - function "=" (Left, Right : Set) return Boolean with - Global => null, - Post => - "="'Result = - (Length (Left) = Length (Right) - and E_Elements_Included (Elements (Left), Elements (Right))) - and - "="'Result = - (E_Elements_Included (Elements (Left), Elements (Right)) - and E_Elements_Included (Elements (Right), Elements (Left))); - -- For each element in Left, set equality attempts to find the equal - -- element in Right; if a search fails, then set equality immediately - -- returns False. The search works by calling Hash to find the bucket in - -- the Right set that corresponds to the Left element. If the bucket is - -- non-empty, the search calls the generic formal element equality operator - -- to compare the element (in Left) to the element of each node in the - -- bucket (in Right); the search terminates when a matching node in the - -- bucket is found, or the nodes in the bucket are exhausted. (Note that - -- element equality is called here, not Equivalent_Elements. Set equality - -- is the only operation in which element equality is used. Compare set - -- equality to Equivalent_Sets, which does call Equivalent_Elements.) - - function Equivalent_Sets (Left, Right : Set) return Boolean with - Global => null, - Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); - -- Similar to set equality, with the difference that the element in Left is - -- compared to the elements in Right using the generic formal - -- Equivalent_Elements operation instead of element equality. - - function To_Set (New_Item : Element_Type) return Set with - Global => null, - Post => - M.Is_Singleton (Model (To_Set'Result), New_Item) - and Length (To_Set'Result) = 1 - and E.Get (Elements (To_Set'Result), 1) = New_Item; - -- Constructs a singleton set comprising New_Element. To_Set calls Hash to - -- determine the bucket for New_Item. - - function Capacity (Container : Set) return Count_Type with - Global => null, - Post => Capacity'Result = Container.Capacity; - -- Returns the current capacity of the set. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => - Model (Container) = Model (Container)'Old - and Length (Container)'Old = Length (Container) - - -- Actual elements are preserved - - and E_Elements_Included - (Elements (Container), Elements (Container)'Old) - and E_Elements_Included - (Elements (Container)'Old, Elements (Container)); - -- If the value of the Capacity actual parameter is less or equal to - -- Container.Capacity, then the operation has no effect. Otherwise it - -- raises Capacity_Error (as no expansion of capacity is possible for a - -- bounded form). - - function Is_Empty (Container : Set) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Set) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - -- Removes all of the items from the set. This will deallocate all memory - -- associated with this set. - - procedure Assign (Target : in out Set; Source : Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Length (Target) = Length (Source) - - -- Actual elements are preserved - - and E_Elements_Included (Elements (Target), Elements (Source)) - and E_Elements_Included (Elements (Source), Elements (Target)); - -- If Target denotes the same object as Source, then the operation has no - -- effect. If the Target capacity is less than the Source length, then - -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then - -- copies the (active) elements from Source to Target. - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Elements (Copy'Result) = Elements (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - -- Constructs a new set object whose elements correspond to Source. If the - -- Capacity parameter is 0, then the capacity of the result is the same as - -- the length of Source. If the Capacity parameter is equal or greater than - -- the length of Source, then the capacity of the result is the specified - -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter - -- is 0, then the modulus of the result is the value returned by a call to - -- Default_Modulus with the capacity parameter determined as above; - -- otherwise the modulus of the result is the specified value. - - function Element - (Container : Set; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Position) - and Positions (Container) = Positions (Container)'Old; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - - procedure Move (Target : in out Set; Source : in out Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Length (Source) = 0 - and Model (Target) = Model (Source)'Old - and Length (Target) = Length (Source)'Old - - -- Actual elements are preserved - - and E_Elements_Included (Elements (Target), Elements (Source)'Old) - and E_Elements_Included (Elements (Source)'Old, Elements (Target)); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Has_Element (Container, Position) - and Equivalent_Elements (Element (Container, Position), New_Item), - Contract_Cases => - - -- If New_Item is already in Container, it is not modified and Inserted - -- is set to False. - - (Contains (Container, New_Item) => - not Inserted - and Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, New_Item is inserted in Container and Inserted is set to - -- True. - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Position)); - -- Conditionally inserts New_Item into the set. If New_Item is already in - -- the set, then Inserted returns False and Position designates the node - -- containing the existing element (which is not modified). If New_Item is - -- not already in the set, then Inserted returns True and Position - -- designates the newly-inserted node containing New_Item. The search for - -- an existing element works as follows. Hash is called to determine - -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements - -- is called to compare New_Item to the element of each node in that - -- bucket. If the bucket is empty, or there were no equivalent elements in - -- the bucket, the search "fails" and the New_Item is inserted in the set - -- (and Inserted returns True); otherwise, the search "succeeds" (and - -- Inserted returns False). - - procedure Insert (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, New_Item) - and Element (Container, Find (Container, New_Item)) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, New_Item)); - -- Attempts to insert New_Item into the set, performing the usual insertion - -- search (which involves calling both Hash and Equivalent_Elements); if - -- the search succeeds (New_Item is equivalent to an element already in the - -- set, and so was not inserted), then this operation raises - -- Constraint_Error. (This version of Insert is similar to Replace, but - -- having the opposite exception behavior. It is intended for use when you - -- want to assert that the item is not already in the set.) - - procedure Include (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Element (Container, Find (Container, New_Item)) = New_Item, - Contract_Cases => - - -- If an element equivalent to New_Item is already in Container, it is - -- replaced by New_Item. - - (Contains (Container, New_Item) => - - -- Elements are preserved modulo equivalence - - Model (Container) = Model (Container)'Old - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The actual value of other elements is preserved - - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - P.Get (Positions (Container), Find (Container, New_Item))), - - -- Otherwise, New_Item is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, New_Item))); - -- Attempts to insert New_Item into the set. If an element equivalent to - -- New_Item is already in the set (the insertion search succeeded, and - -- hence New_Item was not inserted), then the value of New_Item is assigned - -- to the existing element. (This insertion operation only raises an - -- exception if cursor tampering occurs. It is intended for use when you - -- want to insert the item in the set, and you don't care whether an - -- equivalent element is already present.) - - procedure Replace (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => Contains (Container, New_Item), - Post => - - -- Elements are preserved modulo equivalence - - Model (Container) = Model (Container)'Old - and Contains (Container, New_Item) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and Element (Container, Find (Container, New_Item)) = New_Item - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - P.Get (Positions (Container), Find (Container, New_Item))); - -- Searches for New_Item in the set; if the search fails (because an - -- equivalent element was not in the set), then it raises - -- Constraint_Error. Otherwise, the existing element is assigned the value - -- New_Item. (This is similar to Insert, but with the opposite exception - -- behavior. It is intended for use when you want to assert that the item - -- is already in the set.) - - procedure Exclude (Container : in out Set; Item : Element_Type) with - Global => null, - Post => not Contains (Container, Item), - Contract_Cases => - - -- If Item is not in Container, nothing is changed - - (not Contains (Container, Item) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Item is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Item)'Old)); - -- Searches for Item in the set, and if found, removes its node from the - -- set and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the item's bucket; if the bucket is not empty, - -- it calls Equivalent_Elements to compare Item to the element of each node - -- in the bucket. (This is the deletion analog of Include. It is intended - -- for use when you want to remove the item from the set, but don't care - -- whether the item is already in the set.) - - procedure Delete (Container : in out Set; Item : Element_Type) with - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Item is no longer in Container - - and not Contains (Container, Item) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Item)'Old); - -- Searches for Item in the set (which involves calling both Hash and - -- Equivalent_Elements). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the set and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the set.) - - procedure Delete (Container : in out Set; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The element at position Position is no longer in Container - - and not Contains (Container, Element (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Position'Old); - -- Removes the node designated by Position from the set, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Elements). - - procedure Union (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Big (Length (Source)) - - -- Elements already in Target are still in Target - - and Model (Target)'Old <= Model (Target) - - -- Elements of Source are included in Target - - and Model (Source) <= Model (Target) - - -- Elements of Target come from either Source or Target - - and M.Included_In_Union - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - - and E_Elements_Included - (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) - - and E_Elements_Included - (Elements (Source), - Model (Target)'Old, - Elements (Source), - Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target)'Old, - E_Right => Elements (Target), - P_Left => Positions (Target)'Old, - P_Right => Positions (Target)); - -- Iterates over the Source set, and conditionally inserts each element - -- into Target. - - function Union (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Union'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - + Big (Length (Right)) - - -- Elements of Left and Right are in the result of Union - - and Model (Left) <= Model (Union'Result) - and Model (Right) <= Model (Union'Result) - - -- Elements of the result of union come from either Left or Right - - and - M.Included_In_Union - (Model (Union'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Union'Result), - Model (Left), - Elements (Left), - Elements (Right)) - - and E_Elements_Included - (Elements (Left), Model (Left), Elements (Union'Result)) - - and E_Elements_Included - (Elements (Right), - Model (Left), - Elements (Right), - Elements (Union'Result)); - -- The operation first copies the Left set to the result, and then iterates - -- over the Right set to conditionally insert each element into the result. - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are in Source - - and Model (Target) <= Model (Source) - - -- Elements both in Source and Target are in the intersection - - and M.Includes_Intersection - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and E_Elements_Included - (Elements (Target)'Old, Model (Source), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - -- Iterates over the Target set (calling First and Next), calling Find to - -- determine whether the element is in Source. If an equivalent element is - -- not found in Source, the element is deleted from Target. - - function Intersection (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Intersection'Result)) = - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements in the result of Intersection are in Left and Right - - and Model (Intersection'Result) <= Model (Left) - and Model (Intersection'Result) <= Model (Right) - - -- Elements both in Left and Right are in the result of Intersection - - and M.Includes_Intersection - (Model (Intersection'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from Left - - and E_Elements_Included - (Elements (Intersection'Result), Elements (Left)) - - and E_Elements_Included - (Elements (Left), Model (Right), - Elements (Intersection'Result)); - -- Iterates over the Left set, calling Find to determine whether the - -- element is in Right. If an equivalent element is found, it is inserted - -- into the result set. - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are not in Source - - and M.No_Overlap (Model (Target), Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - -- Iterates over the Source (calling First and Next), calling Find to - -- determine whether the element is in Target. If an equivalent element is - -- found, it is deleted from Target. - - function Difference (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Difference'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements of the result of Difference are in Left - - and Model (Difference'Result) <= Model (Left) - - -- Elements of the result of Difference are in Right - - and M.No_Overlap (Model (Difference'Result), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and M.Included_In_Union - (Model (Left), Model (Difference'Result), Model (Right)) - - -- Actual value of elements come from Left - - and E_Elements_Included - (Elements (Difference'Result), Elements (Left)) - - and E_Elements_Included - (Elements (Left), - Model (Difference'Result), - Elements (Difference'Result)); - -- Iterates over the Left set, calling Find to determine whether the - -- element is in the Right set. If an equivalent element is not found, the - -- element is inserted into the result set. - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target) + Length (Target and Source), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Big (Length (Source)) - - -- Elements of the difference were not both in Source and in Target - - and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Elements in Source but not in Target are in the difference - - and M.Included_In_Union - (Model (Source), Model (Target), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - - and E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - and E_Elements_Included - (Elements (Source), Model (Target), Elements (Target)); - -- The operation iterates over the Source set, searching for the element - -- in Target (calling Hash and Equivalent_Elements). If an equivalent - -- element is found, it is removed from Target; otherwise it is inserted - -- into Target. - - function Symmetric_Difference (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) - - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Big (Length (Right)) - - -- Elements of the difference were not both in Left and Right - - and M.Not_In_Both - (Model (Symmetric_Difference'Result), - Model (Left), - Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and M.Included_In_Union - (Model (Left), - Model (Symmetric_Difference'Result), - Model (Right)) - - -- Elements in Right but not in Left are in the difference - - and M.Included_In_Union - (Model (Right), - Model (Symmetric_Difference'Result), - Model (Left)) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Symmetric_Difference'Result), - Model (Left), - Elements (Left), - Elements (Right)) - - and E_Elements_Included - (Elements (Left), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)) - - and E_Elements_Included - (Elements (Right), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)); - -- The operation first iterates over the Left set. It calls Find to - -- determine whether the element is in the Right set. If no equivalent - -- element is found, the element from Left is inserted into the result. The - -- operation then iterates over the Right set, to determine whether the - -- element is in the Left set. If no equivalent element is found, the Right - -- element is inserted into the result. - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean with - Global => null, - Post => - Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); - -- Iterates over the Left set (calling First and Next), calling Find to - -- determine whether the element is in the Right set. If an equivalent - -- element is found, the operation immediately returns True. The operation - -- returns False if the iteration over Left terminates without finding any - -- equivalent element in Right. - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with - Global => null, - Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); - -- Iterates over Subset (calling First and Next), calling Find to determine - -- whether the element is in Of_Set. If no equivalent element is found in - -- Of_Set, the operation immediately returns False. The operation returns - -- True if the iteration over Subset terminates without finding an element - -- not in Of_Set (that is, every element in Subset is equivalent to an - -- element in Of_Set). - - function First (Container : Set) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Container : Set; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Container : Set; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - -- Equivalent to Position := Next (Position) - - function Find - (Container : Set; - Item : Element_Type) return Cursor - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Item) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Item) - - -- The element designated by the result of Find is Item - - and Equivalent_Elements - (Element (Container, Find'Result), Item)); - -- Searches for Item in the set. Find calls Hash to determine the item's - -- bucket; if the bucket is not empty, it calls Equivalent_Elements to - -- compare Item to each element in the bucket. If the search succeeds, Find - -- returns a cursor designating the node containing the equivalent element; - -- otherwise, it returns No_Element. - - function Contains (Container : Set; Item : Element_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Set; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - function Default_Modulus (Capacity : Count_Type) return Hash_Type with - Global => null; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - package Generic_Keys with SPARK_Mode is - - package Formal_Model with Ghost is - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - with - Global => null, - Post => - M_Included_Except'Result = - (for all E of Left => - Contains (Right, E) - or Equivalent_Keys (Generic_Keys.Key (E), Key)); - - end Formal_Model; - use Formal_Model; - - function Key (Container : Set; Position : Cursor) return Key_Type with - Global => null, - Post => Key'Result = Key (Element (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element (Container : Set; Key : Key_Type) return Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Element'Result = Element (Container, Find (Container, Key)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - - -- Key now maps to New_Item - - and Element (Container, Key) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Find (Container, Key)) - and Positions (Container) = Positions (Container)'Old; - - procedure Exclude (Container : in out Set; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old)); - - procedure Delete (Container : in out Set; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old); - - function Find (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - ((for all E of Model (Container) => - not Equivalent_Keys (Key, Generic_Keys.Key (E))) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Generic_Keys.Key (Container, Find'Result), Key)); - - function Contains (Container : Set; Key : Key_Type) return Boolean with - Global => null, - Post => - Contains'Result = - (for some E of Model (Container) => - Equivalent_Keys (Key, Generic_Keys.Key (E))); - - end Generic_Keys; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - - type Node_Type is - record - Element : aliased Element_Type; - Next : Count_Type; - Has_Element : Boolean := False; - end record; - - package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Formal_Hash_Table_Types (Node_Type); - - type Set (Capacity : Count_Type; Modulus : Hash_Type) is record - Content : HT_Types.Hash_Table_Type (Capacity, Modulus); - end record; - - use HT_Types; +package Ada.Containers.Formal_Hashed_Sets with SPARK_Mode is - Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cfidll.adb b/gcc/ada/libgnat/a-cfidll.adb deleted file mode 100644 index 17e48d2..0000000 --- a/gcc/ada/libgnat/a-cfidll.adb +++ /dev/null @@ -1,2054 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_INDEFINITE_DOUBLY_LINKED_LISTS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Stable_Sorting; use Ada.Containers.Stable_Sorting; - -with System; use type System.Address; - -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; - -package body Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with - SPARK_Mode => Off -is - -- Convert Count_Type to Big_Integer - - package Conversions is new Signed_Conversions (Int => Count_Type); - use Conversions; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type); - - procedure Allocate - (Container : in out List; - New_Node : out Count_Type); - - procedure Free (Container : in out List; X : Count_Type); - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type); - - function Vet (L : List; Position : Cursor) return Boolean with Inline; - - procedure Resize (Container : in out List) with - -- Add more room in the internal array - - Global => null, - Pre => Container.Nodes = null - or else Length (Container) = Container.Nodes'Length, - Post => Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old; - - procedure Finalize_Element is new Ada.Unchecked_Deallocation - (Object => Element_Type, - Name => Element_Access); - - procedure Finalize_Nodes is new Ada.Unchecked_Deallocation - (Object => Node_Array, - Name => Node_Array_Access); - - --------- - -- "=" -- - --------- - - function "=" (Left : List; Right : List) return Boolean is - LI : Count_Type; - RI : Count_Type; - - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Length /= Right.Length then - return False; - end if; - - LI := Left.First; - RI := Right.First; - while LI /= 0 loop - if Left.Nodes (LI).Element.all /= Right.Nodes (RI).Element.all then - return False; - end if; - - LI := Left.Nodes (LI).Next; - RI := Right.Nodes (RI).Next; - end loop; - - return True; - end "="; - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (Container : in out List) is - N_Src : Node_Array_Access renames Container.Nodes; - N_Tar : Node_Array_Access; - - begin - if N_Src = null then - return; - end if; - - if Container.Length = 0 then - Container.Nodes := null; - Container.Free := -1; - return; - end if; - - N_Tar := new Node_Array (1 .. N_Src'Length); - - for X in 1 .. Count_Type (N_Src'Length) loop - N_Tar (X) := N_Src (X); - if N_Src (X).Element /= null - then - N_Tar (X).Element := new Element_Type'(N_Src (X).Element.all); - end if; - end loop; - - N_Src := N_Tar; - - end Adjust; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Container : in out List; - New_Node : out Count_Type) - is - N : Node_Array_Access renames Container.Nodes; - - begin - if Container.Nodes = null - or else Length (Container) = Container.Nodes'Length - then - Resize (Container); - end if; - - if Container.Free >= 0 then - New_Node := Container.Free; - Container.Free := N (New_Node).Next; - else - New_Node := abs Container.Free; - Container.Free := Container.Free - 1; - end if; - - N (New_Node).Element := null; - end Allocate; - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type) - is - N : Node_Array_Access renames Container.Nodes; - - begin - Allocate (Container, New_Node); - - N (New_Node).Element := new Element_Type'(New_Item); - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out List; New_Item : Element_Type) is - begin - Insert (Container, No_Element, New_Item, 1); - end Append; - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, No_Element, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out List; Source : List) is - N : Node_Array_Access renames Source.Nodes; - J : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - Clear (Target); - - J := Source.First; - while J /= 0 loop - Append (Target, N (J).Element.all); - J := N (J).Next; - end loop; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - N : Node_Array_Access renames Container.Nodes; - X : Count_Type; - - begin - if Container.Length = 0 then - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - return; - end if; - - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - while Container.Length > 1 loop - X := Container.First; - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - - X := Container.First; - - Container.First := 0; - Container.Last := 0; - Container.Length := 0; - - Free (Container, X); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : List; - Position : Cursor) return not null access constant Element_Type - is - begin - if not Has_Element (Container => Container, Position => Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return Container.Nodes (Position.Node).Element; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : List; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : List) return List - is - N : Count_Type; - P : List; - - begin - if Source.Nodes = null then - return P; - end if; - - P.Nodes := new Node_Array (1 .. Source.Nodes'Length); - - N := 1; - while N <= Source.Nodes'Length loop - P.Nodes (N).Prev := Source.Nodes (N).Prev; - P.Nodes (N).Next := Source.Nodes (N).Next; - if Source.Nodes (N).Element /= null then - P.Nodes (N).Element := - new Element_Type'(Source.Nodes (N).Element.all); - end if; - N := N + 1; - end loop; - - P.Free := Source.Free; - P.Length := Source.Length; - P.First := Source.First; - P.Last := Source.Last; - - return P; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out List; Position : in out Cursor) is - begin - Delete - (Container => Container, - Position => Position, - Count => 1); - end Delete; - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type) - is - N : Node_Array_Access renames Container.Nodes; - X : Count_Type; - - begin - if not Has_Element (Container => Container, - Position => Position) - then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; - return; - end if; - - if Count = 0 then - Position := No_Element; - return; - end if; - - for Index in 1 .. Count loop - pragma Assert (Container.Length >= 2); - - X := Position.Node; - Container.Length := Container.Length - 1; - - if X = Container.Last then - Position := No_Element; - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Free (Container, X); - return; - end if; - - Position.Node := N (X).Next; - pragma Assert (N (Position.Node).Prev >= 0); - - N (N (X).Next).Prev := N (X).Prev; - N (N (X).Prev).Next := N (X).Next; - - Free (Container, X); - end loop; - - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out List) is - begin - Delete_First - (Container => Container, - Count => 1); - end Delete_First; - - procedure Delete_First (Container : in out List; Count : Count_Type) is - N : Node_Array_Access renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - for J in 1 .. Count loop - X := Container.First; - pragma Assert (N (N (X).Next).Prev = Container.First); - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out List) is - begin - Delete_Last - (Container => Container, - Count => 1); - end Delete_Last; - - procedure Delete_Last (Container : in out List; Count : Count_Type) is - N : Node_Array_Access renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (N (N (X).Prev).Next = Container.Last); - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : List; - Position : Cursor) return Element_Type - is - begin - if not Has_Element (Container => Container, Position => Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return Container.Nodes (Position.Node).Element.all; - end Element; - - ---------------- - -- Empty_List -- - ---------------- - - function Empty_List return List is - ((Controlled with others => <>)); - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out List) is - X : Count_Type := Container.First; - N : Node_Array_Access renames Container.Nodes; - begin - - if N = null then - return; - end if; - - while X /= 0 loop - Finalize_Element (N (X).Element); - X := N (X).Next; - end loop; - - Finalize_Nodes (N); - - Container.Free := 0; - Container.Last := 0; - Container.First := 0; - Container.Length := 0; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - From : Count_Type := Position.Node; - - begin - if From = 0 and Container.Length = 0 then - return No_Element; - end if; - - if From = 0 then - From := Container.First; - end if; - - if Position.Node /= 0 and then not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - while From /= 0 loop - if Container.Nodes (From).Element.all = Item then - return (Node => From); - end if; - - From := Container.Nodes (From).Next; - end loop; - - return No_Element; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : List) return Cursor is - begin - if Container.First = 0 then - return No_Element; - end if; - - return (Node => Container.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : List) return Element_Type is - F : constant Count_Type := Container.First; - begin - if F = 0 then - raise Constraint_Error with "list is empty"; - else - return Container.Nodes (F).Element.all; - end if; - end First_Element; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : List) is null; - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - Elem : Element_Type; - - begin - for Index in 1 .. M.Length (Container) loop - Elem := Element (Container, Index); - - if not M.Contains (Left, 1, M.Length (Left), Elem) - and then not M.Contains (Right, 1, M.Length (Right), Elem) - then - return False; - end if; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Positive_Count_Type := 1; - L_Lst : Count_Type; - Right : M.Sequence; - R_Fst : Positive_Count_Type := 1; - R_Lst : Count_Type) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Count_Type := R_Fst - 1; - - begin - while not Found and J < R_Lst loop - J := J + 1; - if Element (Left, I) = Element (Right, J) then - Found := True; - end if; - end loop; - - if not Found then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_Included; - - ------------------------- - -- M_Elements_Reversed -- - ------------------------- - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - is - L : constant Count_Type := M.Length (Left); - - begin - if L /= M.Length (Right) then - return False; - end if; - - for I in 1 .. L loop - if Element (Left, I) /= Element (Right, L - I + 1) then - return False; - end if; - end loop; - - return True; - end M_Elements_Reversed; - - ------------------------ - -- M_Elements_Swapped -- - ------------------------ - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Positive_Count_Type; - Y : Positive_Count_Type) return Boolean - is - begin - if M.Length (Left) /= M.Length (Right) - or else Element (Left, X) /= Element (Right, Y) - or else Element (Left, Y) /= Element (Right, X) - then - return False; - end if; - - for I in 1 .. M.Length (Left) loop - if I /= X and then I /= Y - and then Element (Left, I) /= Element (Right, I) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Swapped; - - ----------- - -- Model -- - ----------- - - function Model (Container : List) return M.Sequence is - Position : Count_Type := Container.First; - R : M.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := M.Add (R, Container.Nodes (Position).Element.all); - Position := Container.Nodes (Position).Next; - end loop; - - return R; - end Model; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (M_Left : M.Sequence; - M_Right : M.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > M.Length (M_Left) - or else P.Get (P_Right, C) > M.Length (M_Right) - or else M.Get (M_Left, P.Get (P_Left, C)) /= - M.Get (M_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - for C of P_Right loop - if not P.Has_Key (P_Left, C) then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------- - -- P_Positions_Shifted -- - ------------------------- - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) + Count - then - return False; - end if; - - else - if P.Has_Key (Small, Cu) then - return False; - end if; - end if; - end; - end loop; - - return True; - end P_Positions_Shifted; - - ------------------------- - -- P_Positions_Swapped -- - ------------------------- - - function P_Positions_Swapped - (Left : P.Map; - Right : P.Map; - X : Cursor; - Y : Cursor) return Boolean - is - begin - if not P.Has_Key (Left, X) - or not P.Has_Key (Left, Y) - or not P.Has_Key (Right, X) - or not P.Has_Key (Right, Y) - then - return False; - end if; - - if P.Get (Left, X) /= P.Get (Right, Y) - or P.Get (Left, Y) /= P.Get (Right, X) - then - return False; - end if; - - for C of Left loop - if not P.Has_Key (Right, C) then - return False; - end if; - end loop; - - for C of Right loop - if not P.Has_Key (Left, C) - or else (C /= X - and C /= Y - and P.Get (Left, C) /= P.Get (Right, C)) - then - return False; - end if; - end loop; - - return True; - end P_Positions_Swapped; - - --------------------------- - -- P_Positions_Truncated -- - --------------------------- - - function P_Positions_Truncated - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - return False; - - elsif P.Has_Key (Small, Cu) then - return False; - end if; - end; - end loop; - - return True; - end P_Positions_Truncated; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : List) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.First; - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = To_Big_Integer (I)); - Position := Container.Nodes (Position).Next; - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (Container : in out List; X : Count_Type) is - pragma Assert (X > 0); - pragma Assert (X <= Container.Nodes'Length); - - N : Node_Array_Access renames Container.Nodes; - - begin - N (X).Prev := -1; -- Node is deallocated (not on active list) - - if N (X).Element /= null then - Finalize_Element (N (X).Element); - end if; - - if Container.Free >= 0 then - N (X).Next := Container.Free; - Container.Free := X; - elsif X + 1 = abs Container.Free then - N (X).Next := 0; -- Not strictly necessary, but marginally safer - Container.Free := Container.Free + 1; - else - Container.Free := abs Container.Free; - - for J in Container.Free .. Container.Nodes'Length loop - N (J).Next := J + 1; - end loop; - - N (Container.Nodes'Length).Next := 0; - - N (X).Next := Container.Free; - Container.Free := X; - end if; - end Free; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting with SPARK_Mode => Off is - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Elements_Sorted -- - ----------------------- - - function M_Elements_Sorted (Container : M.Sequence) return Boolean is - begin - if M.Length (Container) = 0 then - return True; - end if; - - declare - E1 : Element_Type := Element (Container, 1); - - begin - for I in 2 .. M.Length (Container) loop - declare - E2 : constant Element_Type := Element (Container, I); - - begin - if E2 < E1 then - return False; - end if; - - E1 := E2; - end; - end loop; - end; - - return True; - end M_Elements_Sorted; - - end Formal_Model; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : List) return Boolean is - Nodes : Node_Array_Access renames Container.Nodes; - Node : Count_Type := Container.First; - - begin - for J in 2 .. Container.Length loop - if Nodes (Nodes (Node).Next).Element.all < Nodes (Node).Element.all - then - return False; - else - Node := Nodes (Node).Next; - end if; - end loop; - - return True; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out List; Source : in out List) is - LN : Node_Array_Access renames Target.Nodes; - RN : Node_Array_Access renames Source.Nodes; - LI : Cursor; - RI : Cursor; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - LI := First (Target); - RI := First (Source); - while RI.Node /= 0 loop - pragma Assert - (RN (RI.Node).Next = 0 - or else not (RN (RN (RI.Node).Next).Element.all < - RN (RI.Node).Element.all)); - - if LI.Node = 0 then - Splice (Target, No_Element, Source); - return; - end if; - - pragma Assert - (LN (LI.Node).Next = 0 - or else not (LN (LN (LI.Node).Next).Element.all < - LN (LI.Node).Element.all)); - - if RN (RI.Node).Element.all < LN (LI.Node).Element.all then - declare - RJ : Cursor := RI; - pragma Warnings (Off, RJ); - begin - RI.Node := RN (RI.Node).Next; - Splice (Target, LI, Source, RJ); - end; - - else - LI.Node := LN (LI.Node).Next; - end if; - end loop; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out List) is - N : Node_Array_Access renames Container.Nodes; - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - declare - package Descriptors is new List_Descriptors - (Node_Ref => Count_Type, Nil => 0); - use Descriptors; - - function Next (Idx : Count_Type) return Count_Type is - (N (Idx).Next); - procedure Set_Next (Idx : Count_Type; Next : Count_Type) - with Inline; - procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) - with Inline; - function "<" (L, R : Count_Type) return Boolean is - (N (L).Element.all < N (R).Element.all); - procedure Update_Container (List : List_Descriptor) with Inline; - - procedure Set_Next (Idx : Count_Type; Next : Count_Type) is - begin - N (Idx).Next := Next; - end Set_Next; - - procedure Set_Prev (Idx : Count_Type; Prev : Count_Type) is - begin - N (Idx).Prev := Prev; - end Set_Prev; - - procedure Update_Container (List : List_Descriptor) is - begin - Container.First := List.First; - Container.Last := List.Last; - Container.Length := List.Length; - end Update_Container; - - procedure Sort_List is new Doubly_Linked_List_Sort; - begin - Sort_List (List_Descriptor'(First => Container.First, - Last => Container.Last, - Length => Container.Length)); - end; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Sort; - - end Generic_Sorting; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : List; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - end if; - - return Container.Nodes (Position.Node).Prev /= -1; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type) - is - J : Count_Type; - - begin - if Before.Node /= 0 then - pragma Assert (Vet (Container, Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - Allocate (Container, New_Item, New_Node => J); - Insert_Internal (Container, Before.Node, New_Node => J); - Position := (Node => J); - - for Index in 2 .. Count loop - Allocate (Container, New_Item, New_Node => J); - Insert_Internal (Container, Before.Node, New_Node => J); - end loop; - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor) - is - begin - Insert - (Container => Container, - Before => Before, - New_Item => New_Item, - Position => Position, - Count => 1); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type) - is - Position : Cursor; - - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type) - is - Position : Cursor; - - begin - Insert (Container, Before, New_Item, Position, 1); - end Insert; - - --------------------- - -- Insert_Internal -- - --------------------- - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type) - is - N : Node_Array_Access renames Container.Nodes; - - begin - if Container.Length = 0 then - pragma Assert (Before = 0); - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - - Container.First := New_Node; - Container.Last := New_Node; - - N (Container.First).Prev := 0; - N (Container.Last).Next := 0; - - elsif Before = 0 then - pragma Assert (N (Container.Last).Next = 0); - - N (Container.Last).Next := New_Node; - N (New_Node).Prev := Container.Last; - - Container.Last := New_Node; - N (Container.Last).Next := 0; - - elsif Before = Container.First then - pragma Assert (N (Container.First).Prev = 0); - - N (Container.First).Prev := New_Node; - N (New_Node).Next := Container.First; - - Container.First := New_Node; - N (Container.First).Prev := 0; - - else - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - N (New_Node).Next := Before; - N (New_Node).Prev := N (Before).Prev; - - N (N (Before).Prev).Next := New_Node; - N (Before).Prev := New_Node; - end if; - Container.Length := Container.Length + 1; - end Insert_Internal; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : List) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ---------- - -- Last -- - ---------- - - function Last (Container : List) return Cursor is - begin - if Container.Last = 0 then - return No_Element; - end if; - - return (Node => Container.Last); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : List) return Element_Type is - L : constant Count_Type := Container.Last; - - begin - if L = 0 then - raise Constraint_Error with "list is empty"; - else - return Container.Nodes (L).Element.all; - end if; - end Last_Element; - - ------------ - -- Length -- - ------------ - - function Length (Container : List) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out List; Source : in out List) is - N : Node_Array_Access renames Source.Nodes; - - procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation - (Object => Node_Array, - Name => Node_Array_Access); - - begin - if Target'Address = Source'Address then - return; - end if; - - Clear (Target); - - if Source.Length = 0 then - return; - end if; - - -- Make sure that Target is large enough - - if Target.Nodes = null - or else Target.Nodes'Length < Source.Length - then - if Target.Nodes /= null then - Finalize_Node_Array (Target.Nodes); - end if; - Target.Nodes := new Node_Array (1 .. Source.Length); - end if; - - -- Copy first element from Source to Target - - Target.First := 1; - - Target.Nodes (1).Prev := 0; - Target.Nodes (1).Element := N (Source.First).Element; - N (Source.First).Element := null; - - -- Copy the other elements - - declare - X_Src : Count_Type := N (Source.First).Next; - X_Tar : Count_Type := 2; - - begin - while X_Src /= 0 loop - Target.Nodes (X_Tar).Prev := X_Tar - 1; - Target.Nodes (X_Tar - 1).Next := X_Tar; - - Target.Nodes (X_Tar).Element := N (X_Src).Element; - N (X_Src).Element := null; - - X_Src := N (X_Src).Next; - X_Tar := X_Tar + 1; - end loop; - end; - - Target.Last := Source.Length; - Target.Length := Source.Length; - Target.Nodes (Target.Last).Next := 0; - - -- Set up the free list - - Target.Free := -Source.Length - 1; - - -- It is possible to Clear Source because the Element accesses were - -- set to null. - - Clear (Source); - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Container : List; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - function Next (Container : List; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Program_Error with "Position cursor has no element"; - end if; - - return (Node => Container.Nodes (Position.Node).Next); - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend (Container : in out List; New_Item : Element_Type) is - begin - Insert (Container, First (Container), New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, First (Container), New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Container : List; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - function Previous (Container : List; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Program_Error with "Position cursor has no element"; - end if; - - return (Node => Container.Nodes (Position.Node).Prev); - end Previous; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access List; - Position : Cursor) return not null access Element_Type - is - begin - if not Has_Element (Container.all, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return Container.Nodes (Position.Node).Element; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Finalize_Element (Container.Nodes (Position.Node).Element); - Container.Nodes (Position.Node).Element := new Element_Type'(New_Item); - end Replace_Element; - - ------------ - -- Resize -- - ------------ - - procedure Resize (Container : in out List) is - Min_Size : constant Count_Type := 100; - begin - if Container.Nodes = null then - Container.Nodes := new Node_Array (1 .. Min_Size); - Container.First := 0; - Container.Last := 0; - Container.Length := 0; - Container.Free := -1; - - return; - end if; - - if Container.Length /= Container.Nodes'Length then - raise Program_Error with "List must be at size max to resize"; - end if; - - declare - procedure Finalize_Node_Array is new Ada.Unchecked_Deallocation - (Object => Node_Array, - Name => Node_Array_Access); - - New_Size : constant Count_Type := - (if Container.Nodes'Length > Count_Type'Last / 2 - then Count_Type'Last - else 2 * Container.Nodes'Length); - New_Nodes : Node_Array_Access; - - begin - New_Nodes := - new Node_Array (1 .. Count_Type'Max (New_Size, Min_Size)); - - New_Nodes (1 .. Container.Nodes'Length) := - Container.Nodes (1 .. Container.Nodes'Length); - - Container.Free := -Container.Nodes'Length - 1; - - Finalize_Node_Array (Container.Nodes); - Container.Nodes := New_Nodes; - end; - end Resize; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - N : Node_Array_Access renames Container.Nodes; - I : Count_Type := Container.First; - J : Count_Type := Container.Last; - - procedure Swap (L : Count_Type; R : Count_Type); - - ---------- - -- Swap -- - ---------- - - procedure Swap (L : Count_Type; R : Count_Type) is - LN : constant Count_Type := N (L).Next; - LP : constant Count_Type := N (L).Prev; - - RN : constant Count_Type := N (R).Next; - RP : constant Count_Type := N (R).Prev; - - begin - if LP /= 0 then - N (LP).Next := R; - end if; - - if RN /= 0 then - N (RN).Prev := L; - end if; - - N (L).Next := RN; - N (R).Prev := LP; - - if LN = R then - pragma Assert (RP = L); - - N (L).Prev := R; - N (R).Next := L; - - else - N (L).Prev := RP; - N (RP).Next := L; - - N (R).Next := LN; - N (LN).Prev := R; - end if; - end Swap; - - -- Start of processing for Reverse_Elements - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); - - J := N (J).Next; - exit when I = J; - - I := N (I).Prev; - exit when I = J; - - Swap (L => J, R => I); - - I := N (I).Next; - exit when I = J; - - J := N (J).Prev; - exit when I = J; - end loop; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - CFirst : Count_Type := Position.Node; - - begin - if CFirst = 0 then - CFirst := Container.Last; - end if; - - if Container.Length = 0 then - return No_Element; - else - while CFirst /= 0 loop - if Container.Nodes (CFirst).Element.all = Item then - return (Node => CFirst); - else - CFirst := Container.Nodes (CFirst).Prev; - end if; - end loop; - - return No_Element; - end if; - end Reverse_Find; - - ------------ - -- Splice -- - ------------ - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - is - SN : Node_Array_Access renames Source.Nodes; - TN : Node_Array_Access renames Target.Nodes; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Before.Node /= 0 then - pragma Assert (Vet (Target, Before), "bad cursor in Splice"); - end if; - - if Is_Empty (Source) then - return; - end if; - - pragma Assert (SN (Source.First).Prev = 0); - pragma Assert (SN (Source.Last).Next = 0); - - declare - X : Count_Type; - - begin - while not Is_Empty (Source) loop - Allocate (Target, X); - - TN (X).Element := SN (Source.Last).Element; - - -- Insert the new node in Target - - Insert_Internal (Target, Before.Node, X); - - -- Free the last node of Source - - SN (Source.Last).Element := null; - Delete_Last (Source); - end loop; - end; - - end Splice; - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - is - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Source, Position), "bad Position cursor in Splice"); - - declare - X : Count_Type; - - begin - Allocate (Target, X); - - Target.Nodes (X).Element := Source.Nodes (Position.Node).Element; - - -- Insert the new node in Target - - Insert_Internal (Target, Before.Node, X); - - -- Free the node at position Position in Source - - Source.Nodes (Position.Node).Element := null; - Delete (Source, Position); - - Position := (Node => X); - end; - end Splice; - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - is - N : Node_Array_Access renames Container.Nodes; - - begin - if Before.Node /= 0 then - pragma Assert - (Vet (Container, Before), "bad Before cursor in Splice"); - end if; - - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad Position cursor in Splice"); - - if Position.Node = Before.Node - or else N (Position.Node).Next = Before.Node - then - return; - end if; - - pragma Assert (Container.Length >= 2); - - if Before.Node = 0 then - pragma Assert (Position.Node /= Container.Last); - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.Last).Next := Position.Node; - N (Position.Node).Prev := Container.Last; - - Container.Last := Position.Node; - N (Container.Last).Next := 0; - - return; - end if; - - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.First).Prev := Position.Node; - N (Position.Node).Next := Container.First; - - Container.First := Position.Node; - N (Container.First).Prev := 0; - - return; - end if; - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - elsif Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (N (Before.Node).Prev).Next := Position.Node; - N (Position.Node).Prev := N (Before.Node).Prev; - - N (Before.Node).Prev := Position.Node; - N (Position.Node).Next := Before.Node; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Splice; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out List; - I : Cursor; - J : Cursor) - is - begin - if I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Node = J.Node then - return; - end if; - - pragma Assert (Vet (Container, I), "bad I cursor in Swap"); - pragma Assert (Vet (Container, J), "bad J cursor in Swap"); - - declare - NN : Node_Array_Access renames Container.Nodes; - NI : Node_Type renames NN (I.Node); - NJ : Node_Type renames NN (J.Node); - - EI_Copy : constant Element_Access := NI.Element; - - begin - NI.Element := NJ.Element; - NJ.Element := EI_Copy; - end; - end Swap; - - ---------------- - -- Swap_Links -- - ---------------- - - procedure Swap_Links - (Container : in out List; - I : Cursor; - J : Cursor) - is - I_Next : Cursor; - J_Next : Cursor; - - begin - if I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Node = J.Node then - return; - end if; - - pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); - pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); - - I_Next := Next (Container, I); - - if I_Next = J then - Splice (Container, Before => I, Position => J); - - else - J_Next := Next (Container, J); - - if J_Next = I then - Splice (Container, Before => J, Position => I); - - else - pragma Assert (Container.Length >= 3); - Splice (Container, Before => I_Next, Position => J); - Splice (Container, Before => J_Next, Position => I); - end if; - end if; - end Swap_Links; - - --------- - -- Vet -- - --------- - - function Vet (L : List; Position : Cursor) return Boolean is - N : Node_Array_Access renames L.Nodes; - begin - if not Container_Checks'Enabled then - return True; - end if; - - if L.Length = 0 then - return False; - end if; - - if L.First = 0 then - return False; - end if; - - if L.Last = 0 then - return False; - end if; - - if Position.Node > L.Nodes'Length then - return False; - end if; - - if N (Position.Node).Prev < 0 - or else N (Position.Node).Prev > L.Nodes'Length - then - return False; - end if; - - if N (Position.Node).Next > L.Nodes'Length then - return False; - end if; - - if N (L.First).Prev /= 0 then - return False; - end if; - - if N (L.Last).Next /= 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 and then Position.Node /= L.First then - return False; - end if; - - if N (Position.Node).Next = 0 and then Position.Node /= L.Last then - return False; - end if; - - if L.Length = 1 then - return L.First = L.Last; - end if; - - if L.First = L.Last then - return False; - end if; - - if N (L.First).Next = 0 then - return False; - end if; - - if N (L.Last).Prev = 0 then - return False; - end if; - - if N (N (L.First).Next).Prev /= L.First then - return False; - end if; - - if N (N (L.Last).Prev).Next /= L.Last then - return False; - end if; - - if L.Length = 2 then - if N (L.First).Next /= L.Last then - return False; - end if; - - if N (L.Last).Prev /= L.First then - return False; - end if; - - return True; - end if; - - if N (L.First).Next = L.Last then - return False; - end if; - - if N (L.Last).Prev = L.First then - return False; - end if; - - if Position.Node = L.First then - return True; - end if; - - if Position.Node = L.Last then - return True; - end if; - - if N (Position.Node).Next = 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 then - return False; - end if; - - if N (N (Position.Node).Next).Prev /= Position.Node then - return False; - end if; - - if N (N (Position.Node).Prev).Next /= Position.Node then - return False; - end if; - - if L.Length = 3 then - if N (L.First).Next /= Position.Node then - return False; - end if; - - if N (L.Last).Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end Vet; - -end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfidll.ads b/gcc/ada/libgnat/a-cfidll.ads index c4d244a..cbddde3 100644 --- a/gcc/ada/libgnat/a-cfidll.ads +++ b/gcc/ada/libgnat/a-cfidll.ads @@ -29,1642 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; -private with Ada.Finalization; - generic - type Element_Type is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with - SPARK_Mode -is - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - type List is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (List); - - type Cursor is record - Node : Count_Type := 0; - end record; - - No_Element : constant Cursor := Cursor'(Node => 0); - - function Length (Container : List) return Count_Type with - Global => null; - - function Empty_List return List with - Global => null, - Post => Length (Empty_List'Result) = 0; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Positive_Count_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in 1 .. M.Length (Container) => - (for some J in 1 .. M.Length (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in 1 .. M.Length (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Positive_Count_Type := 1; - L_Lst : Count_Type; - Right : M.Sequence; - R_Fst : Positive_Count_Type := 1; - R_Lst : Count_Type) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in 1 .. M.Length (Left) => - Element (Left, I) = - Element (Right, M.Length (Left) - I + 1)) - and (for all I in 1 .. M.Length (Left) => - Element (Right, I) = - Element (Left, M.Length (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Positive_Count_Type; - Y : Positive_Count_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Length (Left) and Y <= M.Length (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function P_Positions_Swapped - (Left : P.Map; - Right : P.Map; - X : Cursor; - Y : Cursor) return Boolean - -- Left and Right contain the same cursors, but the positions of X and Y - -- are reversed. - with - Ghost, - Global => null, - Post => - P_Positions_Swapped'Result = - (P.Same_Keys (Left, Right) - and P.Elements_Equal_Except (Left, Right, X, Y) - and P.Has_Key (Left, X) - and P.Has_Key (Left, Y) - and P.Get (Left, X) = P.Get (Right, Y) - and P.Get (Left, Y) = P.Get (Right, X)); - - function P_Positions_Truncated - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Ghost, - Global => null, - Post => - P_Positions_Truncated'Result = - - -- Big contains all cursors of Small at the same position - - (Small <= Big - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Mapping_Preserved - (M_Left : M.Sequence; - M_Right : M.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Left and Right contain the same cursors - - P.Same_Keys (P_Left, P_Right) - - -- Mappings from cursors to elements induced by M_Left, P_Left - -- and M_Right, P_Right are the same. - - and (for all C of P_Left => - M.Get (M_Left, P.Get (P_Left, C)) = - M.Get (M_Right, P.Get (P_Right, C)))); - - function Model (Container : List) return M.Sequence with - -- The high-level model of a list is a sequence of elements. Cursors are - -- not represented in this model. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); - - function Positions (Container : List) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and map them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : List) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access to the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level cursor-aware view of a container to a high-level - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Elt of Model (Container) => - (for some I of Positions (Container) => - M.Get (Model (Container), P.Get (Positions (Container), I)) = - Elt)); - - function Element - (S : M.Sequence; - I : Count_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : List) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Is_Empty (Container : List) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out List) with - Global => null, - Post => Length (Container) = 0; - - procedure Assign (Target : in out List; Source : List) with - Global => null, - Post => Model (Target) = Model (Source); - - function Copy (Source : List) return List with - Global => null, - Post => - Model (Copy'Result) = Model (Source) - and Positions (Copy'Result) = Positions (Source); - - function Element - (Container : List; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - Element (Model (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Cursors are preserved - - and Positions (Container)'Old = Positions (Container) - - -- The element at the position of Position in Container is New_Item - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- Other elements are preserved - - and M.Equal_Except - (Model (Container)'Old, - Model (Container), - P.Get (Positions (Container), Position)); - - function At_End (E : access constant List) return access constant List - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function At_End - (E : access constant Element_Type) return access constant Element_Type - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function Constant_Reference - (Container : List; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - Element (Model (Container), P.Get (Positions (Container), Position)); - - function Reference - (Container : not null access List; - Position : Cursor) return not null access Element_Type - with - Global => null, - Pre => Has_Element (Container.all, Position), - Post => - Length (Container.all) = Length (At_End (Container).all) - - -- Cursors are preserved - - and Positions (Container.all) = Positions (At_End (Container).all) - - -- Container will have Result.all at position Position - - and At_End (Reference'Result).all = - Element (Model (At_End (Container).all), - P.Get (Positions (At_End (Container).all), Position)) - - -- All other elements are preserved - - and M.Equal_Except - (Model (Container.all), - Model (At_End (Container).all), - P.Get (Positions (At_End (Container).all), Position)); - - procedure Move (Target : in out List; Source : in out List) with - Global => null, - Post => Model (Target) = Model (Source'Old) and Length (Source) = 0; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + 1, - Contract_Cases => - (Before = No_Element => - - -- Positions contains a new mapping from the last cursor of - -- Container to its length. - - P.Get (Positions (Container), Last (Container)) = Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at the previous position of Before in - -- Container. - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = New_Item - - -- A new cursor has been inserted at position Before in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before))); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Count_Type'Last - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Before = No_Element => - - -- The elements of Container are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Before - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => - P.Get (Positions (Container)'Old, Before) - 1 + Count, - Item => New_Item) - - -- Count cursors have been inserted at position Before in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before), - Count => Count)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor) - with - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - and P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = Length (Container) - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at Position in Container - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- A new cursor has been inserted at position Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Count_Type'Last - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Count = 0 => - Position = Before - and Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - others => - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = - Length (Container)'Old + 1 - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Position - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => - P.Get (Positions (Container), Position) - 1 + Count, - Item => New_Item) - - -- Count cursor have been inserted at Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position), - Count => Count)); - - procedure Prepend (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Count_Type'Last, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is the first element of Container - - and Element (Model (Container), 1) = New_Item - - -- A new cursor has been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1); - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Count_Type'Last - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => Count) - - -- Container starts with Count times New_Item - - and M.Constant_Range - (Container => Model (Container), - Fst => 1, - Lst => Count, - Item => New_Item) - - -- Count cursors have been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1, - Count => Count); - - procedure Append (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Count_Type'Last, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions contains a new mapping from the last cursor of Container - -- to its length. - - and P.Get (Positions (Container), Last (Container)) = - Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container); - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Count_Type'Last - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count); - - procedure Delete (Container : in out List; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count < P.Get (Positions (Container), Position) => - Length (Container) = - P.Get (Positions (Container)'Old, Position'Old) - 1 - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => Count) - - -- Count cursors have been removed from Container at Position - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count)); - - procedure Delete_First (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- The first cursor of Container has been removed - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1); - - procedure Delete_First (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => Count) - - -- The first Count cursors have been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1, - Count => Count)); - - procedure Delete_Last (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- The last cursor of Container has been removed - - and not P.Has_Key (Positions (Container), Last (Container)'Old) - - -- Other cursors are still valid - - and P.Keys_Included_Except - (Left => Positions (Container)'Old, - Right => Positions (Container)'Old, - New_Key => Last (Container)'Old) - - -- The positions of other cursors are preserved - - and Positions (Container) <= Positions (Container)'Old; - - procedure Delete_Last (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => Length (Container) + 1, - Count => Count)); - - procedure Reverse_Elements (Container : in out List) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container)'Old, - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - - and Positions (Container) = Positions (Container)'Old; - - procedure Swap_Links - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container'Old), - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - and P_Positions_Swapped - (Positions (Container)'Old, Positions (Container), I, J); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - -- Target and Source should not be aliased - with - Global => null, - Pre => - Length (Source) <= Count_Type'Last - Length (Target) - and then (Has_Element (Target, Before) or else Before = No_Element), - Post => - Length (Source) = 0 - and Length (Target) = Length (Target)'Old + Length (Source)'Old, - Contract_Cases => - (Before = No_Element => - - -- The elements of Target are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => Length (Target)'Old) - - -- The elements of Source are appended to target, the order is not - -- specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => Length (Target)'Old + 1, - R_Lst => Length (Target)) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => Length (Target)'Old + 1, - L_Lst => Length (Target), - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Cursors have been inserted at the end of Target - - and P_Positions_Truncated - (Positions (Target)'Old, - Positions (Target), - Cut => Length (Target)'Old + 1, - Count => Length (Source)'Old), - - others => - - -- The elements of Target located before Before are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target)'Old, Before) - 1) - - -- The elements of Source are inserted before Before, the order is - -- not specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => P.Get (Positions (Target)'Old, Before), - R_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => P.Get (Positions (Target)'Old, Before), - L_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old, - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Other elements are shifted by the length of Source - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target)'Old, Before), - Lst => Length (Target)'Old, - Offset => Length (Source)'Old) - - -- Cursors have been inserted at position Before in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target)'Old, Before), - Count => Length (Source)'Old)); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - -- Target and Source should not be aliased - with - Global => null, - Pre => - (Has_Element (Target, Before) or else Before = No_Element) - and then Has_Element (Source, Position) - and then Length (Target) < Count_Type'Last, - Post => - Length (Target) = Length (Target)'Old + 1 - and Length (Source) = Length (Source)'Old - 1 - - -- The elements of Source located before Position are preserved - - and M.Range_Equal - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => 1, - Lst => P.Get (Positions (Source)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => P.Get (Positions (Source)'Old, Position'Old) + 1, - Lst => Length (Source)'Old, - Offset => -1) - - -- Position has been removed from Source - - and P_Positions_Shifted - (Positions (Source), - Positions (Source)'Old, - Cut => P.Get (Positions (Source)'Old, Position'Old)) - - -- Positions is valid in Target and it is located either before - -- Before if it is valid in Target or at the end if it is No_Element. - - and P.Has_Key (Positions (Target), Position) - and (if Before = No_Element then - P.Get (Positions (Target), Position) = Length (Target) - else - P.Get (Positions (Target), Position) = - P.Get (Positions (Target)'Old, Before)) - - -- The elements of Target located before Position are preserved - - and M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target), Position), - Lst => Length (Target)'Old, - Offset => 1) - - -- The element located at Position in Source is moved to Target - - and Element (Model (Target), - P.Get (Positions (Target), Position)) = - Element (Model (Source)'Old, - P.Get (Positions (Source)'Old, Position'Old)) - - -- A new cursor has been inserted at position Position in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target), Position)); - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - with - Global => null, - Pre => - (Has_Element (Container, Before) or else Before = No_Element) - and then Has_Element (Container, Position), - Post => Length (Container) = Length (Container)'Old, - Contract_Cases => - (Before = Position => - Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - Before = No_Element => - - -- The elements located before Position are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => Length (Container)'Old, - Offset => -1) - - -- The last element of Container is the one that was previously at - -- Position. - - and Element (Model (Container), - Length (Container)) = - Element (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)), - - others => - - -- The elements located before Position and Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => - Count_Type'Min - (P.Get (Positions (Container)'Old, Position) - 1, - P.Get (Positions (Container)'Old, Before) - 1)) - - -- The elements located after Position and Before are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => - Count_Type'Max - (P.Get (Positions (Container)'Old, Position) + 1, - P.Get (Positions (Container)'Old, Before) + 1), - Lst => Length (Container)) - - -- The elements located after Before and before Position are - -- shifted by 1 to the right. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before) + 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1, - Offset => 1) - - -- The elements located after Position and before Before are - -- shifted by 1 to the left. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1, - Offset => -1) - - -- The element previously at Position is now before Before - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = - Element - (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container))); - - function First (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => First_Element'Result = M.Get (Model (Container), 1); - - function Last (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = M.Get (Model (Container), Length (Container)); - - function Next (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container after Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => Length (Container), - Item => Item) - => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Find'Result)) = Item - - -- The result of Find is located after Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Find'Result) >= - P.Get (Positions (Container), Position)) - - -- It is the first occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => - P.Get (Positions (Container), Find'Result) - 1, - Item => Item)); - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container before Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item) - => - Reverse_Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Reverse_Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Reverse_Find'Result)) = Item - - -- The result of Find is located before Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Reverse_Find'Result) <= - P.Get (Positions (Container), Position)) - - -- It is the last occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - P.Get (Positions (Container), - Reverse_Find'Result) + 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item)); - - function Contains - (Container : List; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = M.Contains (Container => Model (Container), - Fst => 1, - Lst => Length (Container), - Item => Item); - - function Has_Element - (Container : List; - Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in 1 .. M.Length (Container) => - (for all J in I .. M.Length (Container) => - not (Element (Container, J) < Element (Container, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : List) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out List) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Length (Container), - Right => Model (Container), - R_Lst => Length (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Length (Container), - Right => Model (Container)'Old, - R_Lst => Length (Container)); - - procedure Merge (Target : in out List; Source : in out List) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Target) <= Count_Type'Last - Length (Source), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Length (Target)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - use Ada.Finalization; - - type Element_Access is access all Element_Type; - - type Node_Type is record - Prev : Count_Type'Base := -1; - Next : Count_Type := 0; - Element : Element_Access := null; - end record; - - type Node_Access is access all Node_Type; - - function "=" (L, R : Node_Type) return Boolean is abstract; - - type Node_Array is array (Count_Type range <>) of Node_Type; - function "=" (L, R : Node_Array) return Boolean is abstract; - - type Node_Array_Access is access all Node_Array; +package Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists with SPARK_Mode is - type List is new Controlled with record - Free : Count_Type'Base := -1; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - Nodes : Node_Array_Access := null; - end record; + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); - overriding procedure Finalize (Container : in out List); - overriding procedure Adjust (Container : in out List); end Ada.Containers.Formal_Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfinse.adb b/gcc/ada/libgnat/a-cfinse.adb deleted file mode 100644 index 7b457f6..0000000 --- a/gcc/ada/libgnat/a-cfinse.adb +++ /dev/null @@ -1,304 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_INFINITE_SEQUENCE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2022-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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/>. -- ------------------------------------------------------------------------------- - -pragma Ada_2012; - -package body Ada.Containers.Functional_Infinite_Sequences -with SPARK_Mode => Off -is - use Containers; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - package Big_From_Count is new Signed_Conversions - (Int => Count_Type); - - function Big (C : Count_Type) return Big_Integer renames - Big_From_Count.To_Big_Integer; - - -- Store Count_Type'Last as a Big Natural because it is often used - - Count_Type_Big_Last : constant Big_Natural := Big (Count_Type'Last); - - function To_Count (C : Big_Natural) return Count_Type; - -- Convert Big_Natural to Count_Type - - --------- - -- "<" -- - --------- - - function "<" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left) < Length (Right) - and then (for all N in Left => - Get (Left, N) = Get (Right, N))); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left) <= Length (Right) - and then (for all N in Left => - Get (Left, N) = Get (Right, N))); - - --------- - -- "=" -- - --------- - - function "=" (Left : Sequence; Right : Sequence) return Boolean is - (Left.Content = Right.Content); - - --------- - -- Add -- - --------- - - function Add (Container : Sequence; New_Item : Element_Type) return Sequence - is - (Add (Container, Last (Container) + 1, New_Item)); - - function Add - (Container : Sequence; - Position : Big_Positive; - New_Item : Element_Type) return Sequence is - (Content => Add (Container.Content, To_Count (Position), New_Item)); - - -------------------- - -- Constant_Range -- - -------------------- - - function Constant_Range - (Container : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Item : Element_Type) return Boolean - is - Count_Fst : constant Count_Type := To_Count (Fst); - Count_Lst : constant Count_Type := To_Count (Lst); - - begin - for J in Count_Fst .. Count_Lst loop - if Get (Container.Content, J) /= Item then - return False; - end if; - end loop; - - return True; - end Constant_Range; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Item : Element_Type) return Boolean - is - Count_Fst : constant Count_Type := To_Count (Fst); - Count_Lst : constant Count_Type := To_Count (Lst); - - begin - for J in Count_Fst .. Count_Lst loop - if Get (Container.Content, J) = Item then - return True; - end if; - end loop; - - return False; - end Contains; - - -------------------- - -- Empty_Sequence -- - -------------------- - - function Empty_Sequence return Sequence is - (Content => <>); - - ------------------ - -- Equal_Except -- - ------------------ - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Big_Positive) return Boolean - is - Count_Pos : constant Count_Type := To_Count (Position); - Count_Lst : constant Count_Type := To_Count (Last (Left)); - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Count_Lst loop - if J /= Count_Pos - and then Get (Left.Content, J) /= Get (Right.Content, J) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Big_Positive; - Y : Big_Positive) return Boolean - is - Count_X : constant Count_Type := To_Count (X); - Count_Y : constant Count_Type := To_Count (Y); - Count_Lst : constant Count_Type := To_Count (Last (Left)); - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Count_Lst loop - if J /= Count_X - and then J /= Count_Y - and then Get (Left.Content, J) /= Get (Right.Content, J) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - --------- - -- Get -- - --------- - - function Get - (Container : Sequence; - Position : Big_Integer) return Element_Type is - (Get (Container.Content, To_Count (Position))); - - ---------- - -- Last -- - ---------- - - function Last (Container : Sequence) return Big_Natural is - (Length (Container)); - - ------------ - -- Length -- - ------------ - - function Length (Container : Sequence) return Big_Natural is - (Big (Length (Container.Content))); - - ----------------- - -- Range_Equal -- - ----------------- - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Big_Positive; - Lst : Big_Natural) return Boolean - is - Count_Fst : constant Count_Type := To_Count (Fst); - Count_Lst : constant Count_Type := To_Count (Lst); - - begin - for J in Count_Fst .. Count_Lst loop - if Get (Left.Content, J) /= Get (Right.Content, J) then - return False; - end if; - end loop; - - return True; - end Range_Equal; - - ------------------- - -- Range_Shifted -- - ------------------- - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Offset : Big_Integer) return Boolean - is - Count_Fst : constant Count_Type := To_Count (Fst); - Count_Lst : constant Count_Type := To_Count (Lst); - - begin - for J in Count_Fst .. Count_Lst loop - if Get (Left.Content, J) /= Get (Right, Big (J) + Offset) then - return False; - end if; - end loop; - - return True; - end Range_Shifted; - - ------------ - -- Remove -- - ------------ - - function Remove - (Container : Sequence; - Position : Big_Positive) return Sequence is - (Content => Remove (Container.Content, To_Count (Position))); - - --------- - -- Set -- - --------- - - function Set - (Container : Sequence; - Position : Big_Positive; - New_Item : Element_Type) return Sequence is - (Content => Set (Container.Content, To_Count (Position), New_Item)); - - -------------- - -- To_Count -- - -------------- - - function To_Count (C : Big_Natural) return Count_Type is - begin - if C > Count_Type_Big_Last then - raise Program_Error with "Big_Integer too large for Count_Type"; - end if; - return Big_From_Count.From_Big_Integer (C); - end To_Count; - -end Ada.Containers.Functional_Infinite_Sequences; diff --git a/gcc/ada/libgnat/a-cfinse.ads b/gcc/ada/libgnat/a-cfinse.ads index d7fdb04..6f517fa 100644 --- a/gcc/ada/libgnat/a-cfinse.ads +++ b/gcc/ada/libgnat/a-cfinse.ads @@ -29,352 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -pragma Ada_2012; -private with Ada.Containers.Functional_Base; -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; - generic - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Functional_Infinite_Sequences with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - type Sequence is private - with Default_Initial_Condition => Length (Sequence) = 0, - Iterable => (First => Iter_First, - Has_Element => Iter_Has_Element, - Next => Iter_Next, - Element => Get); - -- Sequences are empty when default initialized. - -- Quantification over sequences can be done using the regular - -- quantification over its range or directly on its elements with "for of". - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Sequences are axiomatized using Length and Get, providing respectively - -- the length of a sequence and an accessor to its Nth element: - - function Length (Container : Sequence) return Big_Natural with - -- Length of a sequence - - Global => null; - - function Get - (Container : Sequence; - Position : Big_Integer) return Element_Type - -- Access the Element at position Position in Container - - with - Global => null, - Pre => Iter_Has_Element (Container, Position); - - function Last (Container : Sequence) return Big_Natural with - -- Last index of a sequence - - Global => null, - Post => - Last'Result = Length (Container); - pragma Annotate (GNATprove, Inline_For_Proof, Last); - - function First return Big_Positive is (1) with - -- First index of a sequence - - Global => null; - - ------------------------ - -- Property Functions -- - ------------------------ - - function "=" (Left : Sequence; Right : Sequence) return Boolean with - -- Extensional equality over sequences - - Global => null, - Post => - "="'Result = - (Length (Left) = Length (Right) - and then (for all N in Left => Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "="); - - function "<" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a strict subsequence of Right - - Global => null, - Post => - "<"'Result = - (Length (Left) < Length (Right) - and then (for all N in Left => Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<"); - - function "<=" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a subsequence of Right - - Global => null, - Post => - "<="'Result = - (Length (Left) <= Length (Right) - and then (for all N in Left => Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<="); - - function Contains - (Container : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Item : Element_Type) return Boolean - -- Returns True if Item occurs in the range from Fst to Lst of Container - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Contains'Result = - (for some J in Container => - Fst <= J and J <= Lst and Get (Container, J) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Constant_Range - (Container : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Item : Element_Type) return Boolean - -- Returns True if every element of the range from Fst to Lst of Container - -- is equal to Item. - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Constant_Range'Result = - (for all J in Container => - (if Fst <= J and J <= Lst then Get (Container, J) = Item)); - pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Big_Positive) return Boolean - -- Returns True is Left and Right are the same except at position Position - - with - Global => null, - Pre => Position <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all J in Left => - (if J /= Position then - Get (Left, J) = Get (Right, J)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Big_Positive; - Y : Big_Positive) return Boolean - -- Returns True is Left and Right are the same except at positions X and Y - - with - Global => null, - Pre => X <= Last (Left) and Y <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all J in Left => - (if J /= X and J /= Y then - Get (Left, J) = Get (Right, J)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Big_Positive; - Lst : Big_Natural) return Boolean - -- Returns True if the ranges from Fst to Lst contain the same elements in - -- Left and Right. - - with - Global => null, - Pre => Lst <= Last (Left) and Lst <= Last (Right), - Post => - Range_Equal'Result = - (for all J in Left => - (if Fst <= J and J <= Lst then Get (Left, J) = Get (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal); - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Big_Positive; - Lst : Big_Natural; - Offset : Big_Integer) return Boolean - -- Returns True if the range from Fst to Lst in Left contains the same - -- elements as the range from Fst + Offset to Lst + Offset in Right. - - with - Global => null, - Pre => - Lst <= Last (Left) - and then - (if Fst <= Lst then - Offset + Fst >= 1 and Offset + Lst <= Length (Right)), - Post => - Range_Shifted'Result = - ((for all J in Left => - (if Fst <= J and J <= Lst then - Get (Left, J) = Get (Right, J + Offset))) - and - (for all J in Right => - (if Fst + Offset <= J and J <= Lst + Offset then - Get (Left, J - Offset) = Get (Right, J)))); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Set - (Container : Sequence; - Position : Big_Positive; - New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except for the one at position Position which is replaced by New_Item. - - with - Global => null, - Pre => Position <= Last (Container), - Post => - Get (Set'Result, Position) = New_Item - and then Equal_Except (Container, Set'Result, Position); - - function Add (Container : Sequence; New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- plus New_Item at the end. - - with - Global => null, - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Last (Add'Result)) = New_Item - and then Container <= Add'Result; - - function Add - (Container : Sequence; - Position : Big_Positive; - New_Item : Element_Type) return Sequence - with - -- Returns a new sequence which contains the same elements as Container - -- except that New_Item has been inserted at position Position. - - Global => null, - Pre => Position <= Last (Container) + 1, - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Position) = New_Item - and then Range_Equal - (Left => Container, - Right => Add'Result, - Fst => 1, - Lst => Position - 1) - and then Range_Shifted - (Left => Container, - Right => Add'Result, - Fst => Position, - Lst => Last (Container), - Offset => 1); - - function Remove - (Container : Sequence; - Position : Big_Positive) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except that the element at position Position has been removed. - - with - Global => null, - Pre => Position <= Last (Container), - Post => - Length (Remove'Result) = Length (Container) - 1 - and then Range_Equal - (Left => Container, - Right => Remove'Result, - Fst => 1, - Lst => Position - 1) - and then Range_Shifted - (Left => Remove'Result, - Right => Container, - Fst => Position, - Lst => Last (Remove'Result), - Offset => 1); - - function Copy_Element (Item : Element_Type) return Element_Type is (Item); - -- Elements of containers are copied by numerous primitives in this - -- package. This function causes GNATprove to verify that such a copy is - -- valid (in particular, it does not break the ownership policy of SPARK, - -- i.e. it does not contain pointers that could be used to alias mutable - -- data). - - function Empty_Sequence return Sequence with - -- Return an empty Sequence - - Global => null, - Post => Length (Empty_Sequence'Result) = 0; - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - function Iter_First (Container : Sequence) return Big_Integer with - Global => null, - Post => Iter_First'Result = 1; - - function Iter_Has_Element - (Container : Sequence; - Position : Big_Integer) return Boolean - with - Global => null, - Post => Iter_Has_Element'Result = - In_Range (Position, 1, Length (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); - - function Iter_Next - (Container : Sequence; - Position : Big_Integer) return Big_Integer - with - Global => null, - Pre => Iter_Has_Element (Container, Position), - Post => Iter_Next'Result = Position + 1; - -private - pragma SPARK_Mode (Off); - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package Containers is new Ada.Containers.Functional_Base - (Index_Type => Positive_Count_Type, - Element_Type => Element_Type); - - type Sequence is record - Content : Containers.Container; - end record; - - function Iter_First (Container : Sequence) return Big_Integer is (1); +package Ada.Containers.Functional_Infinite_Sequences with SPARK_Mode is - function Iter_Next - (Container : Sequence; - Position : Big_Integer) return Big_Integer - is - (Position + 1); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); - function Iter_Has_Element - (Container : Sequence; - Position : Big_Integer) return Boolean - is - (In_Range (Position, 1, Length (Container))); end Ada.Containers.Functional_Infinite_Sequences; diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb deleted file mode 100644 index a55786d..0000000 --- a/gcc/ada/libgnat/a-cfinve.adb +++ /dev/null @@ -1,1452 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2022, 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode => Off -is - function H (New_Item : Element_Type) return Holder renames To_Holder; - function E (Container : Holder) return Element_Type renames Get; - - Growth_Factor : constant := 2; - -- When growing a container, multiply current capacity by this. Doubling - -- leads to amortized linear-time copying. - - subtype Int is Long_Long_Integer; - - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); - - type Maximal_Array_Ptr is access all Elements_Array (Array_Index) - with Storage_Size => 0; - type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) - with Storage_Size => 0; - - function Elems (Container : in out Vector) return Maximal_Array_Ptr; - function Elemsc - (Container : Vector) return Maximal_Array_Ptr_Const; - -- Returns a pointer to the Elements array currently in use -- either - -- Container.Elements_Ptr or a pointer to Container.Elements. We work with - -- pointers to a bogus array subtype that is constrained with the maximum - -- possible bounds. This means that the pointer is a thin pointer. This is - -- necessary because 'Unrestricted_Access doesn't work when it produces - -- access-to-unconstrained and is returned from a function. - -- - -- Note that this is dangerous: make sure calls to this use an indexed - -- component or slice that is within the bounds 1 .. Length (Container). - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type; - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - - function Current_Capacity (Container : Vector) return Capacity_Range; - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - --------- - -- "=" -- - --------- - - function "=" (Left : Vector; Right : Vector) return Boolean is - begin - if Left'Address = Right'Address then - return True; - end if; - - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Length (Left) loop - if Get_Element (Left, J) /= Get_Element (Right, J) then - return False; - end if; - end loop; - - return True; - end "="; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item); - end Append; - - procedure Append (Container : in out Vector; New_Item : Element_Type) is - begin - Append (Container, New_Item, 1); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - Container.Last := No_Index; - - -- Free element, note that this is OK if Elements_Ptr is null - - Free (Container.Elements_Ptr); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - return Constant_Reference (Elemsc (Container) (I)); - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - is - LS : constant Capacity_Range := Length (Source); - C : Capacity_Range; - - begin - if Capacity = 0 then - C := LS; - elsif Capacity >= LS then - C := Capacity; - else - raise Capacity_Error; - end if; - - return Target : Vector (C) do - Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS); - Target.Last := Source.Last; - end return; - end Copy; - - ---------------------- - -- Current_Capacity -- - ---------------------- - - function Current_Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Length - else - Container.Elements_Ptr.all'Length); - end Current_Capacity; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Vector; Index : Extended_Index) is - begin - Delete (Container, Index, 1); - end Delete; - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - is - Old_Last : constant Index_Type'Base := Container.Last; - Old_Len : constant Count_Type := Length (Container); - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - Off : Count_Type'Base; -- Index expressed as offset from IT'First - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - if Count = 0 then - return; - end if; - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements that aren't being deleted (the requested - -- count was less than the available count), so we must slide them down - -- to Index. We first calculate the index values of the respective array - -- slices, using the wider of Index_Type'Base and Count_Type'Base as the - -- type for intermediate calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Off := Count_Type'Base (Index - Index_Type'First); - New_Last := Old_Last - Index_Type'Base (Count); - else - Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - end if; - - -- The array index values for each slice have already been determined, - -- so we just slide down to Index the elements that weren't deleted. - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - Idx : constant Count_Type := EA'First + Off; - - begin - EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); - Container.Last := New_Last; - end; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Vector) is - begin - Delete_First (Container, 1); - end Delete_First; - - procedure Delete_First (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Vector) is - begin - Delete_Last (Container, 1); - end Delete_Last; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - end if; - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Length (Container) then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - return Get_Element (Container, I); - end; - end Element; - - ----------- - -- Elems -- - ----------- - - function Elems (Container : in out Vector) return Maximal_Array_Ptr is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elems; - - function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elemsc; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - K : Count_Type; - Last : constant Extended_Index := Last_Index (Container); - - begin - K := Capacity_Range (Int (Index) - Int (No_Index)); - for Indx in Index .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K + 1; - end loop; - - return No_Index; - end Find_Index; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, 1); - end if; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - begin - for Index in Index_Type'First .. M.Last (Container) loop - declare - Elem : constant Element_Type := Element (Container, Index); - begin - if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) - and then - not M.Contains - (Right, Index_Type'First, M.Last (Right), Elem) - then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Extended_Index := R_Fst - 1; - - begin - while not Found and J < R_Lst loop - J := J + 1; - if Element (Left, I) = Element (Right, J) then - Found := True; - end if; - end loop; - - if not Found then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_Included; - - ------------------------- - -- M_Elements_Reversed -- - ------------------------- - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - is - L : constant Index_Type := M.Last (Left); - - begin - if L /= M.Last (Right) then - return False; - end if; - - for I in Index_Type'First .. L loop - if Element (Left, I) /= Element (Right, L - I + 1) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Reversed; - - ------------------------ - -- M_Elements_Swapped -- - ------------------------ - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - is - begin - if M.Length (Left) /= M.Length (Right) - or else Element (Left, X) /= Element (Right, Y) - or else Element (Left, Y) /= Element (Right, X) - then - return False; - end if; - - for I in Index_Type'First .. M.Last (Left) loop - if I /= X and then I /= Y - and then Element (Left, I) /= Element (Right, I) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Swapped; - - ----------- - -- Model -- - ----------- - - function Model (Container : Vector) return M.Sequence is - R : M.Sequence; - - begin - for Position in 1 .. Length (Container) loop - R := M.Add (R, E (Elemsc (Container) (Position))); - end loop; - - return R; - end Model; - - end Formal_Model; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting with SPARK_Mode => Off is - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Elements_Sorted -- - ----------------------- - - function M_Elements_Sorted (Container : M.Sequence) return Boolean is - begin - if M.Length (Container) = 0 then - return True; - end if; - - declare - E1 : Element_Type := Element (Container, Index_Type'First); - - begin - for I in Index_Type'First + 1 .. M.Last (Container) loop - declare - E2 : constant Element_Type := Element (Container, I); - - begin - if E2 < E1 then - return False; - end if; - - E1 := E2; - end; - end loop; - end; - - return True; - end M_Elements_Sorted; - - end Formal_Model; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - L : constant Capacity_Range := Length (Container); - - begin - for J in 1 .. L - 1 loop - if Get_Element (Container, J + 1) < Get_Element (Container, J) then - return False; - end if; - end loop; - - return True; - end Is_Sorted; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - function "<" (Left : Holder; Right : Holder) return Boolean is - (E (Left) < E (Right)); - - procedure Sort is new Generic_Array_Sort - (Index_Type => Array_Index, - Element_Type => Holder, - Array_Type => Elements_Array, - "<" => "<"); - - Len : constant Capacity_Range := Length (Container); - - begin - if Container.Last <= Index_Type'First then - return; - else - Sort (Elems (Container) (1 .. Len)); - end if; - end Sort; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out Vector; Source : in out Vector) is - I : Count_Type; - J : Count_Type; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Length (Source) = 0 then - return; - end if; - - if Length (Target) = 0 then - Move (Target => Target, Source => Source); - return; - end if; - - I := Length (Target); - - declare - New_Length : constant Count_Type := I + Length (Source); - - begin - if not Bounded - and then Current_Capacity (Target) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Target, - Capacity_Range'Max - (Current_Capacity (Target) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Target.Last := No_Index + Index_Type'Base (New_Length); - - else - Target.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end; - - declare - TA : Maximal_Array_Ptr renames Elems (Target); - SA : Maximal_Array_Ptr renames Elems (Source); - - begin - J := Length (Target); - while Length (Source) /= 0 loop - if I = 0 then - TA (1 .. J) := SA (1 .. Length (Source)); - Source.Last := No_Index; - exit; - end if; - - if E (SA (Length (Source))) < E (TA (I)) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Length (Source)); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - end Generic_Sorting; - - ----------------- - -- Get_Element -- - ----------------- - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type - is - begin - return E (Elemsc (Container) (Position)); - end Get_Element; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - begin - return Position in First_Index (Container) .. Last_Index (Container); - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - is - begin - Insert (Container, Before, New_Item, 1); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - is - J : Count_Type'Base; -- scratch - - begin - -- Use Insert_Space to create the "hole" (the destination slice) - - Insert_Space (Container, Before, Count); - - J := To_Array_Index (Before); - - Elems (Container) (J .. J - 1 + Count) := [others => H (New_Item)]; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - B : Count_Type; -- index Before converted to Count_Type - - begin - if Container'Address = New_Item'Address then - raise Program_Error with - "Container and New_Item denote same container"; - end if; - - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - B := To_Array_Index (Before); - - Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Length (Container); - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before - 1 > Container.Last - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, so we - -- simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion - -- count. Note that we cannot simply add these values, because of the - -- possibility of overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - J := To_Array_Index (Before); - - -- Increase the capacity of container if needed - - if not Bounded - and then Current_Capacity (Container) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Container, - Capacity_Range'Max - (Current_Capacity (Container) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - - begin - if Before <= Container.Last then - - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. - - EA (J + Count .. New_Length) := EA (J .. Old_Length); - end if; - end; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Last_Index (Container) < Index_Type'First; - end Is_Empty; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, Length (Container)); - end if; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Capacity_Range is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Capacity_Range (N); - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Vector; Source : in out Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - Clear (Source); - end Move; - - ------------ - -- Prepend -- - ------------ - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) is - begin - Prepend (Container, New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - if Container.Elements_Ptr = null then - return Reference (Container.Elements (I)'Access); - else - return Reference (Container.Elements_Ptr (I)'Access); - end if; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - Elems (Container) (I) := H (New_Item); - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - is - begin - if Bounded then - if Capacity > Container.Capacity then - raise Constraint_Error with "Capacity is out of range"; - end if; - - else - if Capacity > Current_Capacity (Container) then - declare - New_Elements : constant Elements_Array_Ptr := - new Elements_Array (1 .. Capacity); - L : constant Capacity_Range := Length (Container); - - begin - New_Elements (1 .. L) := Elemsc (Container) (1 .. L); - Free (Container.Elements_Ptr); - Container.Elements_Ptr := New_Elements; - end; - end if; - end if; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Length (Container) <= 1 then - return; - end if; - - declare - I : Capacity_Range; - J : Capacity_Range; - E : Elements_Array renames - Elems (Container) (1 .. Length (Container)); - - begin - I := 1; - J := Length (Container); - while I < J loop - declare - EI : constant Holder := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - Last : Index_Type'Base; - K : Count_Type'Base; - - begin - if Index > Last_Index (Container) then - Last := Last_Index (Container); - else - Last := Index; - end if; - - K := Capacity_Range (Int (Last) - Int (No_Index)); - for Indx in reverse Index_Type'First .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K - 1; - end loop; - - return No_Index; - end Reverse_Find_Index; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - is - begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - declare - II : constant Int'Base := Int (I) - Int (No_Index); - JJ : constant Int'Base := Int (J) - Int (No_Index); - - EI : Holder renames Elems (Container) (Capacity_Range (II)); - EJ : Holder renames Elems (Container) (Capacity_Range (JJ)); - - EI_Copy : constant Holder := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - -------------------- - -- To_Array_Index -- - -------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is - Offset : Count_Type'Base; - - begin - -- We know that - -- Index >= Index_Type'First - -- hence we also know that - -- Index - Index_Type'First >= 0 - - -- The issue is that even though 0 is guaranteed to be a value in the - -- type Index_Type'Base, there's no guarantee that the difference is a - -- value in that type. To prevent overflow we use the wider of - -- Count_Type'Base and Index_Type'Base to perform intermediate - -- calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Offset := Count_Type'Base (Index - Index_Type'First); - - else - Offset := Count_Type'Base (Index) - - Count_Type'Base (Index_Type'First); - end if; - - -- The array index subtype for all container element arrays always - -- starts with 1. - - return 1 + Offset; - end To_Array_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return - (Capacity => Length, - Last => Last, - Elements_Ptr => <>, - Elements => [others => H (New_Item)]); - end; - end To_Vector; - -end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads index f44e45b..dcec6ba 100644 --- a/gcc/ada/libgnat/a-cfinve.ads +++ b/gcc/ada/libgnat/a-cfinve.ads @@ -29,959 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- Similar to Ada.Containers.Formal_Vectors. The main difference is that --- Element_Type may be indefinite (but not an unconstrained array). - -with Ada.Containers.Bounded_Holders; -with Ada.Containers.Functional_Vectors; - generic - type Index_Type is range <>; - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - Max_Size_In_Storage_Elements : Natural; - -- Maximum size of Vector elements in bytes. This has the same meaning as - -- in Ada.Containers.Bounded_Holders, with the same restrictions. Note that - -- setting this too small can lead to erroneous execution; see comments in - -- Ada.Containers.Bounded_Holders. If Element_Type is class-wide, it is the - -- responsibility of clients to calculate the maximum size of all types in - -- the class. - - Bounded : Boolean := True; - -- If True, the containers are bounded; the initial capacity is the maximum - -- size, and heap allocation will be avoided. If False, the containers can - -- grow via heap allocation. - -package Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then - 0 - elsif Index_Type'Last < -1 - or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then - Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else - Count_Type'Last); - -- Maximal capacity of any vector. It is the minimum of the size of the - -- index range and the last possible Count_Type. - - subtype Capacity_Range is Count_Type range 0 .. Last_Count; - - type Vector (Capacity : Capacity_Range) is limited private with - Default_Initial_Condition => Is_Empty (Vector); - -- In the bounded case, Capacity is the capacity of the container, which - -- never changes. In the unbounded case, Capacity is the initial capacity - -- of the container, and operations such as Reserve_Capacity and Append can - -- increase the capacity. The capacity never shrinks, except in the case of - -- Clear. - -- - -- Note that all objects of type Vector are constrained, including in the - -- unbounded case; you can't assign from one object to another if the - -- Capacity is different. - - function Length (Container : Vector) return Capacity_Range with - Global => null, - Post => Length'Result <= Capacity (Container); - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Index_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for some J in Index_Type'First .. M.Last (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in Index_Type'First .. M.Last (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in Index_Type'First .. M.Last (Left) => - Element (Left, I) = - Element (Right, M.Last (Left) - I + 1)) - and (for all I in Index_Type'First .. M.Last (Right) => - Element (Right, I) = - Element (Left, M.Last (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Last (Left) and Y <= M.Last (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - function Model (Container : Vector) return M.Sequence with - -- The high-level model of a vector is a sequence of elements. The - -- sequence really is similar to the vector itself. However, it is not - -- limited which allows usage of 'Old and 'Loop_Entry attributes. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - - function Element - (S : M.Sequence; - I : Index_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function Empty_Vector return Vector with - Global => null, - Post => Length (Empty_Vector'Result) = 0; - - function "=" (Left, Right : Vector) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - with - Global => null, - Post => - Formal_Indefinite_Vectors.Length (To_Vector'Result) = Length - and M.Constant_Range - (Container => Model (To_Vector'Result), - Fst => Index_Type'First, - Lst => Last_Index (To_Vector'Result), - Item => New_Item); - - function Capacity (Container : Vector) return Capacity_Range with - Global => null, - Post => - Capacity'Result = - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - pragma Annotate (GNATprove, Inline_For_Proof, Capacity); - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - with - Global => null, - Pre => (if Bounded then Capacity <= Container.Capacity), - Post => Model (Container) = Model (Container)'Old; - - function Is_Empty (Container : Vector) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Vector) with - Global => null, - Post => Length (Container) = 0; - -- Note that this reclaims storage in the unbounded case. You need to call - -- this before a container goes out of scope in order to avoid storage - -- leaks. In addition, "X := ..." can leak unless you Clear(X) first. - - procedure Assign (Target : in out Vector; Source : Vector) with - Global => null, - Pre => (if Bounded then Length (Source) <= Target.Capacity), - Post => Model (Target) = Model (Source); - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - with - Global => null, - Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)), - Post => - Model (Copy'Result) = Model (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Length (Source) - else - Copy'Result.Capacity = Capacity); - - procedure Move (Target : in out Vector; Source : in out Vector) - with - Global => null, - Pre => (if Bounded then Length (Source) <= Capacity (Target)), - Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => Element'Result = Element (Model (Container), Index); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - - -- Container now has New_Item at index Index - - and Element (Model (Container), Index) = New_Item - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container)'Old, - Right => Model (Container), - Position => Index); - - function At_End (E : access constant Vector) return access constant Vector - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function At_End - (E : access constant Element_Type) return access constant Element_Type - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Constant_Reference'Result.all = Element (Model (Container), Index); - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - with - Global => null, - Pre => - Index in First_Index (Container.all) .. Last_Index (Container.all), - Post => - Length (Container.all) = Length (At_End (Container).all) - - -- Container will have Result.all at index Index - - and At_End (Reference'Result).all = - Element (Model (At_End (Container).all), Index) - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container.all), - Right => Model (At_End (Container).all), - Position => Index); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item) - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Elements of New_Item are inserted at position Before - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => Count_Type (Before - Index_Type'First))) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Capacity (Container) - and then (Before in Index_Type'First .. Last_Index (Container) + 1), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Container now has New_Item at index Before - - and Element (Model (Container), Before) = New_Item - - -- Elements located after Before in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Count - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- New_Item is inserted Count times at position Before - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Before, - Lst => Before + Index_Type'Base (Count - 1), - Item => New_Item)) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Prepend (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements of New_Item are inserted at the beginning of Container - - and M.Range_Equal - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item)) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Container now has New_Item at Index_Type'First - - and Element (Model (Container), Index_Type'First) = New_Item - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- New_Item is inserted Count times at the beginning of Container - - and M.Constant_Range - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Index_Type'First + Index_Type'Base (Count - 1), - Item => New_Item) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Append (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Elements of New_Item are inserted at the end of Container - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => - Count_Type - (Last_Index (Container)'Old - Index_Type'First + 1))); - - procedure Append (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements of Container are preserved - - and Model (Container)'Old < Model (Container) - - -- Container now has New_Item at the end of Container - - and Element - (Model (Container), Last_Index (Container)'Old + 1) = New_Item; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- New_Item is inserted Count times at the end of Container - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Last_Index (Container)'Old + 1, - Lst => - Last_Index (Container)'Old + Index_Type'Base (Count), - Item => New_Item)); - - procedure Delete (Container : in out Vector; Index : Extended_Index) with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements located before Index in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1) - - -- Elements located after Index in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - with - Global => null, - Pre => - Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- The elements of Container located before Index are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => - Length (Container) = Count_Type (Index - Index_Type'First), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_First (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete_First (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_Last (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are preserved - - and Model (Container) < Model (Container)'Old; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old); - - procedure Reverse_Elements (Container : in out Vector) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - with - Global => null, - Pre => - I in First_Index (Container) .. Last_Index (Container) - and then J in First_Index (Container) .. Last_Index (Container), - Post => - M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); - - function First_Index (Container : Vector) return Index_Type with - Global => null, - Post => First_Index'Result = Index_Type'First; - pragma Annotate (GNATprove, Inline_For_Proof, First_Index); - - function First_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = Element (Model (Container), Index_Type'First); - pragma Annotate (GNATprove, Inline_For_Proof, First_Element); - - function Last_Index (Container : Vector) return Extended_Index with - Global => null, - Post => Last_Index'Result = M.Last (Model (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); - - function Last_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = - Element (Model (Container), Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container after Index, Find_Index - -- returns No_Index. - - (Index > Last_Index (Container) - or else not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Last_Index (Container), - Item => Item) - => - Find_Index'Result = No_Index, - - -- Otherwise, Find_Index returns a valid index greater than Index - - others => - Find_Index'Result in Index .. Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Find_Index'Result) = Item - - -- It is the first occurrence of Item after Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Find_Index'Result - 1, - Item => Item)); - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container before Index, - -- Reverse_Find_Index returns No_Index. - - (not M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => (if Index <= Last_Index (Container) then Index - else Last_Index (Container)), - Item => Item) - => - Reverse_Find_Index'Result = No_Index, - - -- Otherwise, Reverse_Find_Index returns a valid index smaller than - -- Index - - others => - Reverse_Find_Index'Result in Index_Type'First .. Index - and Reverse_Find_Index'Result <= Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Reverse_Find_Index'Result) = Item - - -- It is the last occurrence of Item before Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Reverse_Find_Index'Result + 1, - Lst => - (if Index <= Last_Index (Container) then - Index - else - Last_Index (Container)), - Item => Item)); - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = - M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container), - Item => Item); - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for all J in I .. M.Last (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : Vector) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out Vector) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Last_Index (Container), - Right => Model (Container), - R_Lst => Last_Index (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Last_Index (Container), - Right => Model (Container)'Old, - R_Lst => Last_Index (Container)); - - procedure Merge (Target : in out Vector; Source : in out Vector) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Capacity (Target) - Length (Target), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Last_Index (Target)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Last_Index (Source)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Replace_Element); - pragma Inline (Contains); - - -- The implementation method is to instantiate Bounded_Holders to get a - -- definite type for Element_Type. - - package Holders is new Bounded_Holders - (Element_Type, Max_Size_In_Storage_Elements, "="); - use Holders; - - subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; - type Elements_Array is array (Array_Index range <>) of aliased Holder; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Elements_Array_Ptr is access all Elements_Array; - - type Vector (Capacity : Capacity_Range) is limited record - - -- In the bounded case, the elements are stored in Elements. In the - -- unbounded case, the elements are initially stored in Elements, until - -- we run out of room, then we switch to Elements_Ptr. - - Last : Extended_Index := No_Index; - Elements_Ptr : Elements_Array_Ptr := null; - Elements : aliased Elements_Array (1 .. Capacity); - end record; - - -- The primary reason Vector is limited is that in the unbounded case, once - -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will - -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr, - -- so for example "Append (X, ...);" will modify BOTH X and Y. That would - -- allow SPARK to "prove" things that are false. We could fix that by - -- making Vector a controlled type, and override Adjust to make a deep - -- copy, but finalization is not allowed in SPARK. - -- - -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not - -- allowed on Vectors. +package Ada.Containers.Formal_Indefinite_Vectors with SPARK_Mode is - function Empty_Vector return Vector is - ((Capacity => 0, others => <>)); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb deleted file mode 100644 index 38d15e7..0000000 --- a/gcc/ada/libgnat/a-cforma.adb +++ /dev/null @@ -1,1239 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2022, 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); - -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Ordered_Maps with - SPARK_Mode => Off -is - - -- Convert Count_Type to Big_Interger - - package Conversions is new Signed_Conversions (Int => Count_Type); - - function Big (J : Count_Type) return Big_Integer renames - Conversions.To_Big_Integer; - - ----------------------------- - -- Node Access Subprograms -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color - (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type; - pragma Inline (Color); - - function Left_Son (Node : Node_Type) return Count_Type; - pragma Inline (Left_Son); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right_Son (Node : Node_Type) return Count_Type; - pragma Inline (Right_Son); - - procedure Set_Color - (Node : in out Node_Type; - Color : Ada.Containers.Red_Black_Trees.Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All need comments ??? - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type); - - procedure Free (Tree : in out Map; X : Count_Type); - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations - (Tree_Types => Tree_Types, - Left => Left_Son, - Right => Right_Son); - - use Tree_Operations; - - package Key_Ops is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - Lst : Count_Type; - Node : Count_Type; - ENode : Count_Type; - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Is_Empty (Left) then - return True; - end if; - - Lst := Next (Left.Content, Last (Left).Node); - - Node := First (Left).Node; - while Node /= Lst loop - ENode := Find (Right, Left.Content.Nodes (Node).Key).Node; - - if ENode = 0 or else - Left.Content.Nodes (Node).Element /= - Right.Content.Nodes (ENode).Element - then - return False; - end if; - - Node := Next (Left.Content, Node); - end loop; - - return True; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Content.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Key_Ops.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Key_Ops.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Target.Content, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Key := SN.Key; - Node.Element := SN.Element; - end Set_Element; - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target.Content, - Hint => 0, - Key => SN.Key, - Node => Target_Node); - end Append_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Storage_Error with "not enough capacity"; -- SE or CE? ??? - end if; - - Tree_Operations.Clear_Tree (Target.Content); - Append_Elements (Source.Content); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Ceiling (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - Tree_Operations.Clear_Tree (Container.Content); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return not null access constant Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in function Constant_Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - is - Node : constant Node_Access := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map is - Node : Count_Type := 1; - N : Count_Type; - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do - if Length (Source) > 0 then - Target.Content.Length := Source.Content.Length; - Target.Content.Root := Source.Content.Root; - Target.Content.First := Source.Content.First; - Target.Content.Last := Source.Content.Last; - Target.Content.Free := Source.Content.Free; - - while Node <= Source.Capacity loop - Target.Content.Nodes (Node).Element := - Source.Content.Nodes (Node).Element; - Target.Content.Nodes (Node).Key := - Source.Content.Nodes (Node).Key; - Target.Content.Nodes (Node).Parent := - Source.Content.Nodes (Node).Parent; - Target.Content.Nodes (Node).Left := - Source.Content.Nodes (Node).Left; - Target.Content.Nodes (Node).Right := - Source.Content.Nodes (Node).Right; - Target.Content.Nodes (Node).Color := - Source.Content.Nodes (Node).Color; - Target.Content.Nodes (Node).Has_Element := - Source.Content.Nodes (Node).Has_Element; - Node := Node + 1; - end loop; - - while Node <= Target.Capacity loop - N := Node; - Free (Tree => Target, X => N); - Node := Node + 1; - end loop; - end if; - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Delete has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of Delete is bad"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, - Position.Node); - Free (Container, Position.Node); - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : constant Node_Access := Key_Ops.Find (Container.Content, Key); - - begin - if X = 0 then - raise Constraint_Error with "key not in map"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Map) is - X : constant Node_Access := First (Container).Node; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Map) is - X : constant Node_Access := Last (Container).Node; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Element has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of function Element is bad"); - - return Container.Content.Nodes (Position.Node).Element; - - end Element; - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - return Container.Content.Nodes (Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : constant Node_Access := Key_Ops.Find (Container.Content, Key); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.Content.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Map) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (First (Container).Node).Element; - end First_Element; - - --------------- - -- First_Key -- - --------------- - - function First_Key (Container : Map) return Key_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (First (Container).Node).Key; - end First_Key; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Floor (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------- - -- Find -- - ---------- - - function Find - (Container : K.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. K.Length (Container) loop - if Equivalent_Keys (Key, K.Get (Container, I)) then - return I; - elsif Key < K.Get (Container, I) then - return 0; - end if; - end loop; - return 0; - end Find; - - ------------------------- - -- K_Bigger_Than_Range -- - ------------------------- - - function K_Bigger_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (K.Get (Container, I) < Key) then - return False; - end if; - end loop; - return True; - end K_Bigger_Than_Range; - - --------------- - -- K_Is_Find -- - --------------- - - function K_Is_Find - (Container : K.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Key < K.Get (Container, I) then - return False; - end if; - end loop; - - if Position < K.Length (Container) then - for I in Position + 1 .. K.Length (Container) loop - if K.Get (Container, I) < Key then - return False; - end if; - end loop; - end if; - return True; - end K_Is_Find; - - -------------------------- - -- K_Smaller_Than_Range -- - -------------------------- - - function K_Smaller_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Key < K.Get (Container, I)) then - return False; - end if; - end loop; - return True; - end K_Smaller_Than_Range; - - ---------- - -- Keys -- - ---------- - - function Keys (Container : Map) return K.Sequence is - Position : Count_Type := Container.Content.First; - R : K.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := K.Add (R, Container.Content.Nodes (Position).Key); - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Keys; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Map) is null; - - ----------- - -- Model -- - ----------- - - function Model (Container : Map) return M.Map is - Position : Count_Type := Container.Content.First; - R : M.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - New_Key => Container.Content.Nodes (Position).Key, - New_Item => Container.Content.Nodes (Position).Element); - - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - ------------------------- - -- P_Positions_Shifted -- - ------------------------- - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) + Count - then - return False; - end if; - - else - if P.Has_Key (Small, Cu) then - return False; - end if; - end if; - end; - end loop; - - return True; - end P_Positions_Shifted; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Map) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.Content.First; - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = Big (I)); - Position := Tree_Operations.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free - (Tree : in out Map; - X : Count_Type) - is - begin - Tree.Content.Nodes (X).Has_Element := False; - Tree_Operations.Free (Tree.Content, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type) - is - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - begin - Allocate (Tree, Node); - Tree.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Map; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - end if; - - return Container.Content.Nodes (Position.Node).Has_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - declare - N : Node_Type renames Container.Content.Nodes (Position.Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - -- Comment ??? - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - procedure Initialize (Node : in out Node_Type); - procedure Allocate_Node is new Generic_Allocate (Initialize); - - procedure Initialize (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Initialize; - - X : Node_Access; - - begin - Allocate_Node (Container.Content, X); - return X; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container.Content, - Key, - Position.Node, - Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with "key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - -- k > node same as node < k - - return Right.Key < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Key; - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Container : Map; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Key has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of function Key is bad"); - - return Container.Content.Nodes (Position.Node).Key; - end Key; - - ---------- - -- Last -- - ---------- - - function Last (Container : Map) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.Content.Last); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Map) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (Last (Container).Node).Element; - end Last_Element; - - -------------- - -- Last_Key -- - -------------- - - function Last_Key (Container : Map) return Key_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Content.Nodes (Last (Container).Node).Key; - end Last_Key; - - -------------- - -- Left_Son -- - -------------- - - function Left_Son (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left_Son; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Map; Source : in out Map) is - NN : Tree_Types.Nodes_Type renames Source.Content.Nodes; - X : Node_Access; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - loop - X := First (Source).Node; - exit when X = 0; - - -- Here we insert a copy of the source element into the target, and - -- then delete the element from the source. Another possibility is - -- that delete it first (and hang onto its index), then insert it. - -- ??? - - Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - - Tree_Operations.Delete_Node_Sans_Free (Source.Content, X); - Formal_Ordered_Maps.Free (Source, X); - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Container : Map; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - function Next (Container : Map; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Next"); - - return (Node => Tree_Operations.Next (Container.Content, Position.Node)); - end Next; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Container : Map; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - function Previous (Container : Map; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Count_Type := - Tree_Operations.Previous (Container.Content, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Previous; - - -------------- - -- Reference -- - -------------- - - function Reference - (Container : not null access Map; - Position : Cursor) return not null access Element_Type - is - begin - if not Has_Element (Container.all, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container.Content, Position.Node), - "bad cursor in function Reference"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Reference; - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - is - Node : constant Count_Type := Find (Container.all, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Content.Nodes (Node).Element'Access; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - begin - declare - Node : constant Node_Access := Key_Ops.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - declare - N : Node_Type renames Container.Content.Nodes (Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Replace_Element has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "Position cursor of Replace_Element is bad"); - - Container.Content.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - --------------- - -- Right_Son -- - --------------- - - function Right_Son (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right_Son; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - -end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads index 7be2eec..21a5d78 100644 --- a/gcc/ada/libgnat/a-cforma.ads +++ b/gcc/ada/libgnat/a-cforma.ads @@ -29,1124 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Ordered_Maps in --- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Key, Element, Next, Query_Element, Previous, --- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the --- need to have cursors which are valid on different containers (typically a --- container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. The operators "<" and ">" that could not be modified that way --- have been removed. - --- Iteration over maps is done using the Iterable aspect, which is SPARK --- compatible. "For of" iteration ranges over keys instead of elements. - -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; -private with Ada.Containers.Red_Black_Trees; - generic - type Key_Type is private; - type Element_Type is private; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Ordered_Maps with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean with - Global => null, - Post => - Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); - - type Map (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Key), - Default_Initial_Condition => Is_Empty (Map); - pragma Preelaborable_Initialization (Map); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - Empty_Map : constant Map; - - function Length (Container : Map) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Maps - (Element_Type => Element_Type, - Key_Type => Key_Type, - Equivalent_Keys => Equivalent_Keys); - - function "=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."="; - - function "<=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."<="; - - package K is new Ada.Containers.Functional_Vectors - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."="; - - function "<" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<"; - - function "<=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<="; - - function K_Bigger_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= K.Length (Container), - Post => - K_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => K.Get (Container, I) < Key); - pragma Annotate (GNATprove, Inline_For_Proof, K_Bigger_Than_Range); - - function K_Smaller_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= K.Length (Container), - Post => - K_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => Key < K.Get (Container, I)); - pragma Annotate (GNATprove, Inline_For_Proof, K_Smaller_Than_Range); - - function K_Is_Find - (Container : K.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= K.Length (Container), - Post => - K_Is_Find'Result = - ((if Position > 0 then - K_Bigger_Than_Range (Container, 1, Position - 1, Key)) - - and - (if Position < K.Length (Container) then - K_Smaller_Than_Range - (Container, - Position + 1, - K.Length (Container), - Key))); - pragma Annotate (GNATprove, Inline_For_Proof, K_Is_Find); - - function Find (Container : K.Sequence; Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= K.Length (Container) - and Equivalent_Keys (Key, K.Get (Container, Find'Result))); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Model (Container : Map) return M.Map with - -- The high-level model of a map is a map from keys to elements. Neither - -- cursors nor order of elements are represented in this model. Keys are - -- modeled up to equivalence. - - Ghost, - Global => null; - - function Keys (Container : Map) return K.Sequence with - -- The Keys sequence represents the underlying list structure of maps - -- that is used for iteration. It stores the actual values of keys in - -- the map. It does not model cursors nor elements. - - Ghost, - Global => null, - Post => - K.Length (Keys'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Key of Keys'Result => - M.Has_Key (Model (Container), Key)) - - -- It contains all the keys contained in Model - - and (for all Key of Model (Container) => - (Find (Keys'Result, Key) > 0 - and then Equivalent_Keys - (K.Get (Keys'Result, Find (Keys'Result, Key)), - Key))) - - -- It is sorted in increasing order - - and (for all I in 1 .. Length (Container) => - Find (Keys'Result, K.Get (Keys'Result, I)) = I - and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I)); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); - - function Positions (Container : Map) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length. - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Map) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Key of Keys (Container) => - (for some I of Positions (Container) => - K.Get (Keys (Container), P.Get (Positions (Container), I)) = - Key)); - - function Contains - (C : M.Map; - K : Key_Type) return Boolean renames M.Has_Key; - -- To improve readability of contracts, we rename the function used to - -- search for a key in the model to Contains. - - function Element - (C : M.Map; - K : Key_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : Map) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Is_Empty (Container : Map) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Map) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Map; Source : Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Keys (Target) = Keys (Source) - and Length (Source) = Length (Target); - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Keys (Copy'Result) = Keys (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Key (Container : Map; Position : Cursor) return Key_Type with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Key'Result = - K.Get (Keys (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element - (Container : Map; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = Element (Model (Container), Key (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old - - -- New_Item is now associated with the key at position Position in - -- Container. - - and Element (Container, Position) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key (Container, Position)); - - function At_End - (E : not null access constant Map) return not null access constant Map - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function At_End - (E : access constant Element_Type) return access constant Element_Type - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - Element (Model (Container), Key (Container, Position)); - - function Reference - (Container : not null access Map; - Position : Cursor) return not null access Element_Type - with - Global => null, - Pre => Has_Element (Container.all, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with the key at position Position in Container. - - and Element (At_End (Container).all, Position) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key (At_End (Container).all, Position)); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return not null access constant Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Constant_Reference'Result.all = Element (Model (Container), Key); - - function Reference - (Container : not null access Map; - Key : Key_Type) return not null access Element_Type - with - Global => null, - Pre => Contains (Container.all, Key), - Post => - - -- Order of keys and cursors is preserved - - Keys (At_End (Container).all) = Keys (Container.all) - and Positions (At_End (Container).all) = Positions (Container.all) - - -- The value designated by the result of Reference is now associated - -- with Key in Container. - - and Element (Model (At_End (Container).all), Key) = - At_End (Reference'Result).all - - -- Elements associated with other keys are preserved - - and M.Same_Keys - (Model (At_End (Container).all), - Model (Container.all)) - and M.Elements_Equal_Except - (Model (At_End (Container).all), - Model (Container.all), - Key); - - procedure Move (Target : in out Map; Source : in out Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Keys (Target) = Keys (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) - and Has_Element (Container, Position) - and Equivalent_Keys - (Formal_Ordered_Maps.Key (Container, Position), Key) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Position)), - Contract_Cases => - - -- If Key is already in Container, it is not modified and Inserted is - -- set to False. - - (Contains (Container, Key) => - not Inserted - and Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is inserted in Container and Inserted is set to True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Key now maps to New_Item - - and Formal_Ordered_Maps.Key (Container, Position) = Key - and Element (Model (Container), Key) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- The keys of Container located before Position are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted at position Position in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position))); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, Key)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, Key) - - -- Key now maps to New_Item - - and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key - and Element (Model (Container), Key) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => Find (Keys (Container), Key), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Keys (Container), Key)); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) and Element (Container, Key) = New_Item, - Contract_Cases => - - -- If Key is already in Container, Key is mapped to New_Item - - (Contains (Container, Key) => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), Find (Keys (Container), Key)) = Key - - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - Find (Keys (Container), Key)) - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key), - - -- Otherwise, Key is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Key is inserted in Container - - and K.Get - (Keys (Container), Find (Keys (Container), Key)) = Key - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => Find (Keys (Container), Key), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Keys (Container), Key))); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - Find (Keys (Container), Key)) - - -- New_Item is now associated with the Key in Container - - and Element (Model (Container), Key) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key); - - procedure Exclude (Container : in out Map; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key)'Old - 1) - - -- The keys located after Key are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => Find (Keys (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Keys (Container), Key)'Old)); - - procedure Delete (Container : in out Map; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key)'Old - 1) - - -- The keys located after Key are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => Find (Keys (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Keys (Container), Key)'Old); - - procedure Delete (Container : in out Map; Position : in out Cursor) with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The key at position Position is no longer in Container - - and not Contains (Container, Key (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key (Container, Position)'Old) - - -- The keys of Container located before Position are preserved. - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The keys located after Position are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete_First (Container : in out Map) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The first key has been removed from Container - - and not Contains (Container, First_Key (Container)'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - First_Key (Container)'Old) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- First has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1)); - - procedure Delete_Last (Container : in out Map) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The last key has been removed from Container - - and not Contains (Container, Last_Key (Container)'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Last_Key (Container)'Old) - - -- Others keys of Container are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Length (Container)) - - -- Last cursor has been removed from Container - - and Positions (Container) <= Positions (Container)'Old); - - function First (Container : Map) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : Map) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = - Element (Model (Container), First_Key (Container)); - - function First_Key (Container : Map) return Key_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Key'Result = K.Get (Keys (Container), 1) - and K_Smaller_Than_Range - (Keys (Container), 2, Length (Container), First_Key'Result); - - function Last (Container : Map) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : Map) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = Element (Model (Container), Last_Key (Container)); - - function Last_Key (Container : Map) return Key_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Key'Result = K.Get (Keys (Container), Length (Container)) - and K_Bigger_Than_Range - (Keys (Container), 1, Length (Container) - 1, Last_Key'Result); - - function Next (Container : Map; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : Map; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : Map; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : Map; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Key) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Keys (Container), Key) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Formal_Ordered_Maps.Key (Container, Find'Result), Key)); - - function Element (Container : Map; Key : Key_Type) return Element_Type with - Global => null, - Pre => Contains (Container, Key), - Post => Element'Result = Element (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - function Floor (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Key < First_Key (Container) => - Floor'Result = No_Element, - - others => - Has_Element (Container, Floor'Result) - and not (Key < K.Get (Keys (Container), - P.Get (Positions (Container), Floor'Result))) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Last_Key (Container) < Key => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and not (K.Get - (Keys (Container), - P.Get (Positions (Container), Ceiling'Result)) < Key) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Map; Key : Key_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Map; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - pragma Inline (Previous); - - subtype Node_Access is Count_Type; - - use Red_Black_Trees; - - type Node_Type is record - Has_Element : Boolean := False; - Parent : Node_Access := 0; - Left : Node_Access := 0; - Right : Node_Access := 0; - Color : Red_Black_Trees.Color_Type := Red; - Key : Key_Type; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Map (Capacity : Count_Type) is record - Content : Tree_Types.Tree_Type (Capacity); - end record; +package Ada.Containers.Formal_Ordered_Maps with SPARK_Mode is - Empty_Map : constant Map := (Capacity => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb deleted file mode 100644 index e5cddde..0000000 --- a/gcc/ada/libgnat/a-cforse.adb +++ /dev/null @@ -1,1939 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2022, 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); - -with System; use type System.Address; - -package body Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode => Off -is - - ------------------------------ - -- Access to Fields of Node -- - ------------------------------ - - -- These subprograms provide functional notation for access to fields - -- of a node, and procedural notation for modifiying these fields. - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; - pragma Inline (Color); - - function Left_Son (Node : Node_Type) return Count_Type; - pragma Inline (Left_Son); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right_Son (Node : Node_Type) return Count_Type; - pragma Inline (Right_Son); - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- Comments needed??? - - procedure Assign - (Target : in out Tree_Types.Tree_Type; - Source : Tree_Types.Tree_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type); - - procedure Free (Tree : in out Set; X : Count_Type); - - procedure Insert_Sans_Hint - (Container : in out Tree_Types.Tree_Type; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Insert_With_Hint - (Dst_Set : in out Tree_Types.Tree_Type; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean; - pragma Inline (Is_Less_Node_Node); - - procedure Replace_Element - (Tree : in out Set; - Node : Count_Type; - Item : Element_Type); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations - (Tree_Types, - Left => Left_Son, - Right => Right_Son); - - use Tree_Operations; - - package Element_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - package Set_Ops is - new Red_Black_Trees.Generic_Bounded_Set_Operations - (Tree_Operations => Tree_Operations, - Set_Type => Tree_Types.Tree_Type, - Assign => Assign, - Insert_With_Hint => Insert_With_Hint, - Is_Less => Is_Less_Node_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - Lst : Count_Type; - Node : Count_Type; - ENode : Count_Type; - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Is_Empty (Left) then - return True; - end if; - - Lst := Next (Left.Content, Last (Left).Node); - - Node := First (Left).Node; - while Node /= Lst loop - ENode := Find (Right, Left.Content.Nodes (Node).Element).Node; - if ENode = 0 - or else Left.Content.Nodes (Node).Element /= - Right.Content.Nodes (ENode).Element - then - return False; - end if; - - Node := Next (Left.Content, Node); - end loop; - - return True; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign - (Target : in out Tree_Types.Tree_Type; - Source : Tree_Types.Tree_Type) - is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Target, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := SN.Element; - end Set_Element; - - -- Local variables - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target, - Hint => 0, - Key => SN.Element, - Node => Target_Node); - end Append_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error - with "Target capacity is less than Source length"; - end if; - - Tree_Operations.Clear_Tree (Target); - Append_Elements (Source); - end Assign; - - procedure Assign (Target : in out Set; Source : Set) is - begin - Assign (Target.Content, Source.Content); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := - Element_Keys.Ceiling (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - Tree_Operations.Clear_Tree (Container.Content); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Element"); - - return Container.Content.Nodes (Position.Node).Element'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set is - Node : Count_Type; - N : Count_Type; - Target : Set (Count_Type'Max (Source.Capacity, Capacity)); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - if Length (Source) > 0 then - Target.Content.Length := Source.Content.Length; - Target.Content.Root := Source.Content.Root; - Target.Content.First := Source.Content.First; - Target.Content.Last := Source.Content.Last; - Target.Content.Free := Source.Content.Free; - - Node := 1; - while Node <= Source.Capacity loop - Target.Content.Nodes (Node).Element := - Source.Content.Nodes (Node).Element; - Target.Content.Nodes (Node).Parent := - Source.Content.Nodes (Node).Parent; - Target.Content.Nodes (Node).Left := - Source.Content.Nodes (Node).Left; - Target.Content.Nodes (Node).Right := - Source.Content.Nodes (Node).Right; - Target.Content.Nodes (Node).Color := - Source.Content.Nodes (Node).Color; - Target.Content.Nodes (Node).Has_Element := - Source.Content.Nodes (Node).Has_Element; - Node := Node + 1; - end loop; - - while Node <= Target.Capacity loop - N := Node; - Free (Tree => Target, X => N); - Node := Node + 1; - end loop; - end if; - - return Target; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Delete"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, - Position.Node); - Free (Container, Position.Node); - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container.Content, Item); - - begin - if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - X : constant Count_Type := Container.Content.First; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - X : constant Count_Type := Container.Content.Last; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Difference (Target.Content, Source.Content); - end Difference; - - function Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Left) = 0 then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - return S : Set (Length (Left)) do - Assign - (S.Content, Set_Ops.Set_Difference (Left.Content, Right.Content)); - end return; - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Element"); - - return Container.Content.Nodes (Position.Node).Element; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - function Is_Equivalent_Node_Node - (L, R : Node_Type) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is - begin - if L.Element < R.Element then - return False; - elsif R.Element < L.Element then - return False; - else - return True; - end if; - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Content, Right.Content); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container.Content, Item); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.Content.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - Fst : constant Count_Type := First (Container).Node; - begin - if Fst = 0 then - raise Constraint_Error with "set is empty"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return N (Fst).Element; - end; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - begin - declare - Node : constant Count_Type := - Element_Keys.Floor (Container.Content, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Bigger_Than_Range -- - ------------------------- - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (E.Get (Container, I) < Item) then - return False; - end if; - end loop; - - return True; - end E_Bigger_Than_Range; - - ------------------------- - -- E_Elements_Included -- - ------------------------- - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - declare - Item : constant Element_Type := E.Get (Left, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Container) loop - declare - Item : constant Element_Type := E.Get (Container, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Left, 1, E.Length (Left), Item) then - return False; - end if; - else - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - --------------- - -- E_Is_Find -- - --------------- - - function E_Is_Find - (Container : E.Sequence; - Item : Element_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Item < E.Get (Container, I) then - return False; - end if; - end loop; - - if Position < E.Length (Container) then - for I in Position + 1 .. E.Length (Container) loop - if E.Get (Container, I) < Item then - return False; - end if; - end loop; - end if; - - return True; - end E_Is_Find; - - -------------------------- - -- E_Smaller_Than_Range -- - -------------------------- - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Item < E.Get (Container, I)) then - return False; - end if; - end loop; - - return True; - end E_Smaller_Than_Range; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Elements (Item, E.Get (Container, I)) then - return I; - end if; - end loop; - - return 0; - end Find; - - -------------- - -- Elements -- - -------------- - - function Elements (Container : Set) return E.Sequence is - Position : Count_Type := Container.Content.First; - R : E.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := E.Add (R, Container.Content.Nodes (Position).Element); - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Elements; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Set) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------------ - -- Mapping_Preserved_Except -- - ------------------------------ - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - is - begin - for C of P_Left loop - if C /= Position - and (not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C))) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved_Except; - - ------------------------- - -- P_Positions_Shifted -- - ------------------------- - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) + Count - then - return False; - end if; - - else - if P.Has_Key (Small, Cu) then - return False; - end if; - end if; - end; - end loop; - - return True; - end P_Positions_Shifted; - - ----------- - -- Model -- - ----------- - - function Model (Container : Set) return M.Set is - Position : Count_Type := Container.Content.First; - R : M.Set; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - Item => Container.Content.Nodes (Position).Element); - - Position := Tree_Operations.Next (Container.Content, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Set) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.Content.First; - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = Big (I)); - Position := Tree_Operations.Next (Container.Content, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (Tree : in out Set; X : Count_Type) is - begin - Tree.Content.Nodes (X).Has_Element := False; - Tree_Operations.Free (Tree.Content, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type) - is - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - begin - Allocate (Tree, Node); - Tree.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys with SPARK_Mode => Off is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := - Key_Keys.Ceiling (Container.Content, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container.Content, Key); - - begin - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return N (Node).Element; - end; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - if X /= 0 then - Delete_Node_Sans_Free (Container.Content, X); - Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Floor (Container.Content, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Bigger_Than_Range -- - ------------------------- - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Generic_Keys.Key (E.Get (Container, I)) < Key) then - return False; - end if; - end loop; - return True; - end E_Bigger_Than_Range; - - --------------- - -- E_Is_Find -- - --------------- - - function E_Is_Find - (Container : E.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Key < Generic_Keys.Key (E.Get (Container, I)) then - return False; - end if; - end loop; - - if Position < E.Length (Container) then - for I in Position + 1 .. E.Length (Container) loop - if Generic_Keys.Key (E.Get (Container, I)) < Key then - return False; - end if; - end loop; - end if; - return True; - end E_Is_Find; - - -------------------------- - -- E_Smaller_Than_Range -- - -------------------------- - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Key < Generic_Keys.Key (E.Get (Container, I))) then - return False; - end if; - end loop; - return True; - end E_Smaller_Than_Range; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Keys - (Key, Generic_Keys.Key (E.Get (Container, I))) - then - return I; - end if; - end loop; - return 0; - end Find; - - ----------------------- - -- M_Included_Except -- - ----------------------- - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - is - begin - for E of Left loop - if not Contains (Right, E) - and not Equivalent_Keys (Generic_Keys.Key (E), Key) - then - return False; - end if; - end loop; - return True; - end M_Included_Except; - end Formal_Model; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Key (Right.Element) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Key (Right.Element); - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Container : Set; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Key"); - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return Key (N (Position.Node).Element); - end; - end Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container.Content, Key); - begin - if not Has_Element (Container, (Node => Node)) then - raise Constraint_Error with - "attempt to replace key not in set"; - else - Replace_Element (Container, Node, New_Item); - end if; - end Replace; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Set; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - else - return Container.Content.Nodes (Position.Node).Has_Element; - end if; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - N (Position.Node).Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert_Sans_Hint (Container.Content, New_Item, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Container : in out Tree_Types.Tree_Type; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Set_Element (Node : in out Node_Type); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Conditional_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Set_Element; - - -- Start of processing for Insert_Sans_Hint - - begin - Conditional_Insert_Sans_Hint - (Container, - New_Item, - Node, - Inserted); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Set : in out Tree_Types.Tree_Type; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type) - is - Success : Boolean; - - procedure Set_Element (Node : in out Node_Type); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Insert_Post, Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Dst_Set, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := Src_Node.Element; - end Set_Element; - - -- Start of processing for Insert_With_Hint - - begin - Local_Insert_With_Hint - (Dst_Set, - Dst_Hint, - Src_Node.Element, - Dst_Node, - Success); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Intersection (Target.Content, Source.Content); - end Intersection; - - function Intersection (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - return S : Set (Count_Type'Min (Length (Left), Length (Right))) do - Assign (S.Content, - Set_Ops.Set_Intersection (Left.Content, Right.Content)); - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - -- Compute e > node same as node < e - - return Right.Element < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Element; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean is - begin - return L.Element < R.Element; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - begin - return Set_Ops.Set_Subset (Subset.Content, Of_Set => Of_Set.Content); - end Is_Subset; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - return (if Length (Container) = 0 - then No_Element - else (Node => Container.Content.Last)); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Last (Container).Node = 0 then - raise Constraint_Error with "set is empty"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Content.Nodes; - begin - return N (Last (Container).Node).Element; - end; - end Last_Element; - - -------------- - -- Left_Son -- - -------------- - - function Left_Son (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left_Son; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Content.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - N : Tree_Types.Nodes_Type renames Source.Content.Nodes; - X : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - loop - X := Source.Content.First; - exit when X = 0; - - Insert (Target, N (X).Element); -- optimize??? - - Tree_Operations.Delete_Node_Sans_Free (Source.Content, X); - Free (Source, X); - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Container : Set; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Next"); - return (Node => Tree_Operations.Next (Container.Content, Position.Node)); - end Next; - - procedure Next (Container : Set; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - begin - return Set_Ops.Set_Overlap (Left.Content, Right.Content); - end Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - function Previous (Container : Set; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Count_Type := - Tree_Operations.Previous (Container.Content, Position.Node); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end; - end Previous; - - procedure Previous (Container : Set; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Count_Type := - Element_Keys.Find (Container.Content, New_Item); - - begin - if Node = 0 then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - Container.Content.Nodes (Node).Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Tree : in out Set; - Node : Count_Type; - Item : Element_Type) - is - pragma Assert (Node /= 0); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Local_Insert_Post, - Local_Insert_Sans_Hint); - - NN : Tree_Types.Nodes_Type renames Tree.Content.Nodes; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - N : Node_Type renames NN (Node); - begin - N.Element := Item; - N.Color := Red; - N.Parent := 0; - N.Right := 0; - N.Left := 0; - return Node; - end New_Node; - - Hint : Count_Type; - Result : Count_Type; - Inserted : Boolean; - - -- Start of processing for Insert - - begin - if Item < NN (Node).Element - or else NN (Node).Element < Item - then - null; - - else - NN (Node).Element := Item; - return; - end if; - - Hint := Element_Keys.Ceiling (Tree.Content, Item); - - if Hint = 0 then - null; - - elsif Item < NN (Hint).Element then - if Hint = Node then - NN (Node).Element := Item; - return; - end if; - - else - pragma Assert (not (NN (Hint).Element < Item)); - raise Program_Error with "attempt to replace existing element"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree.Content, Node); - - Local_Insert_With_Hint - (Tree => Tree.Content, - Position => Hint, - Key => Item, - Node => Result, - Inserted => Inserted); - - pragma Assert (Inserted); - pragma Assert (Result = Node); - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container.Content, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container, Position.Node, New_Item); - end Replace_Element; - - --------------- - -- Right_Son -- - --------------- - - function Right_Son (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right_Son; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type) - is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Symmetric_Difference (Target.Content, Source.Content); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - return S : Set (Length (Left) + Length (Right)) do - Assign - (S.Content, - Set_Ops.Set_Symmetric_Difference (Left.Content, Right.Content)); - end return; - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Node : Count_Type; - Inserted : Boolean; - - begin - return S : Set (Capacity => 1) do - Insert_Sans_Hint (S.Content, New_Item, Node, Inserted); - pragma Assert (Inserted); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Union (Target.Content, Source.Content); - end Union; - - function Union (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - if Length (Left) = 0 then - return Copy (Right); - end if; - - if Length (Right) = 0 then - return Copy (Left); - end if; - - return S : Set (Length (Left) + Length (Right)) do - Assign (S, Source => Left); - Union (S, Right); - end return; - end Union; - -end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads index ff96d8e..fe5de2b 100644 --- a/gcc/ada/libgnat/a-cforse.ads +++ b/gcc/ada/libgnat/a-cforse.ads @@ -29,1785 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Ordered_Sets in --- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Key, Element, Next, Query_Element, Previous, --- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the --- need to have cursors which are valid on different containers (typically --- a container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. The operators "<" and ">" that could not be modified that way --- have been removed. - -with Ada.Containers.Functional_Maps; -with Ada.Containers.Functional_Sets; -with Ada.Containers.Functional_Vectors; -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; -private with Ada.Containers.Red_Black_Trees; - generic - type Element_Type is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - -- Convert Count_Type to Big_Interger - - package Conversions is new Signed_Conversions (Int => Count_Type); - - function Big (J : Count_Type) return Big_Integer renames - Conversions.To_Big_Integer; - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean - with - Global => null, - Post => - Equivalent_Elements'Result = - (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Elements); - - type Set (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (Set); - pragma Preelaborable_Initialization (Set); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Set) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Sets - (Element_Type => Element_Type, - Equivalent_Elements => Equivalent_Elements); - - function "=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."="; - - function "<=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."<="; - - package E is new Ada.Containers.Functional_Vectors - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."="; - - function "<" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<"; - - function "<=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<="; - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => E.Get (Container, I) < Item); - pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => Item < E.Get (Container, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); - - function E_Is_Find - (Container : E.Sequence; - Item : Element_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= E.Length (Container), - Post => - E_Is_Find'Result = - - ((if Position > 0 then - E_Bigger_Than_Range (Container, 1, Position - 1, Item)) - - and (if Position < E.Length (Container) then - E_Smaller_Than_Range - (Container, - Position + 1, - E.Length (Container), - Item))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - -- Search for Item in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Elements (Item, E.Get (Container, Find'Result))); - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Left are contained in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - (if M.Contains (Model, E.Get (Left, I)) then - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Left and others - -- are in Right. - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Container) => - (if M.Contains (Model, E.Get (Container, I)) then - Find (Left, E.Get (Container, I)) > 0 - and then E.Get (Left, Find (Left, E.Get (Container, I))) = - E.Get (Container, I) - else - Find (Right, E.Get (Container, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Container, I))) = - E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the elements of Left - - and E_Elements_Included (E_Left, E_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same. - - and (for all C of P_Left => - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C)))); - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved_Except'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same except for Position. - - and (for all C of P_Left => - (if C /= Position then - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C))))); - - function Model (Container : Set) return M.Set with - -- The high-level model of a set is a set of elements. Neither cursors - -- nor order of elements are represented in this model. Elements are - -- modeled up to equivalence. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Big (Length (Container)); - - function Elements (Container : Set) return E.Sequence with - -- The Elements sequence represents the underlying list structure of - -- sets that is used for iteration. It stores the actual values of - -- elements in the set. It does not model cursors. - - Ghost, - Global => null, - Post => - E.Length (Elements'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Item of Elements'Result => - M.Contains (Model (Container), Item)) - - -- It contains all the elements contained in Model - - and (for all Item of Model (Container) => - (Find (Elements'Result, Item) > 0 - and then Equivalent_Elements - (E.Get (Elements'Result, Find (Elements'Result, Item)), - Item))) - - -- It is sorted in increasing order - - and (for all I in 1 .. Length (Container) => - Find (Elements'Result, E.Get (Elements'Result, I)) = I - and - E_Is_Find - (Elements'Result, E.Get (Elements'Result, I), I)); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); - - function Positions (Container : Set) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Set) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Item of Elements (Container) => - (for some I of Positions (Container) => - E.Get (Elements (Container), P.Get (Positions (Container), I)) = - Item)); - - function Contains - (C : M.Set; - K : Element_Type) return Boolean renames M.Contains; - -- To improve readability of contracts, we rename the function used to - -- search for an element in the model to Contains. - - end Formal_Model; - use Formal_Model; - - Empty_Set : constant Set; - - function "=" (Left, Right : Set) return Boolean with - Global => null, - Post => - - -- If two sets are equal, they contain the same elements in the same - -- order. - - (if "="'Result then Elements (Left) = Elements (Right) - - -- If they are different, then they do not contain the same elements - - else - not E_Elements_Included (Elements (Left), Elements (Right)) - or not E_Elements_Included (Elements (Right), Elements (Left))); - - function Equivalent_Sets (Left, Right : Set) return Boolean with - Global => null, - Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); - - function To_Set (New_Item : Element_Type) return Set with - Global => null, - Post => - M.Is_Singleton (Model (To_Set'Result), New_Item) - and Length (To_Set'Result) = 1 - and E.Get (Elements (To_Set'Result), 1) = New_Item; - - function Is_Empty (Container : Set) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Set) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Set; Source : Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Elements (Target) = Elements (Source) - and Length (Target) = Length (Source); - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Elements (Copy'Result) = Elements (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Element - (Container : Set; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Position) - and Positions (Container) = Positions (Container)'Old; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return not null access constant Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Constant_Reference'Result.all = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - - procedure Move (Target : in out Set; Source : in out Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Elements (Target) = Elements (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Has_Element (Container, Position) - and Equivalent_Elements (Element (Container, Position), New_Item) - and E_Is_Find - (Elements (Container), - New_Item, - P.Get (Positions (Container), Position)), - Contract_Cases => - - -- If New_Item is already in Container, it is not modified and Inserted - -- is set to False. - - (Contains (Container, New_Item) => - not Inserted - and Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, New_Item is inserted in Container and Inserted is set to - -- True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- The elements of Container located before Position are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted at position Position in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position))); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, New_Item) - - -- New_Item is inserted in the set - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- The elements of Container located before New_Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), New_Item) - 1) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => Find (Elements (Container), New_Item), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Elements (Container), New_Item)); - - procedure Include - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => Contains (Container, New_Item), - Contract_Cases => - - -- If New_Item is already in Container - - (Contains (Container, New_Item) => - - -- Elements are preserved - - Model (Container)'Old = Model (Container) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - Find (Elements (Container), New_Item)), - - -- Otherwise, New_Item is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- New_Item is inserted in Container - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - -- The Elements of Container located before New_Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), New_Item) - 1) - - -- Other Elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => Find (Elements (Container), New_Item), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Elements (Container), New_Item))); - - procedure Replace - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, New_Item), - Post => - - -- Elements are preserved - - Model (Container)'Old = Model (Container) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - Find (Elements (Container), New_Item)); - - procedure Exclude - (Container : in out Set; - Item : Element_Type) - with - Global => null, - Post => not Contains (Container, Item), - Contract_Cases => - - -- If Item is not in Container, nothing is changed - - (not Contains (Container, Item) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Item is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- The elements of Container located before Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Item)'Old - 1) - - -- The elements located after Item are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Item)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Item)'Old)); - - procedure Delete - (Container : in out Set; - Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Item is no longer in Container - - and not Contains (Container, Item) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- The elements of Container located before Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Item)'Old - 1) - - -- The elements located after Item are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Item)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Item)'Old); - - procedure Delete - (Container : in out Set; - Position : in out Cursor) - with - Global => null, - Depends => (Container =>+ Position, Position => null), - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The element at position Position is no longer in Container - - and not Contains (Container, Element (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - - -- The elements of Container located before Position are preserved. - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete_First (Container : in out Set) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The first element has been removed from Container - - and not Contains (Container, First_Element (Container)'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - First_Element (Container)'Old) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- First has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1)); - - procedure Delete_Last (Container : in out Set) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The last element has been removed from Container - - and not Contains (Container, Last_Element (Container)'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Last_Element (Container)'Old) - - -- Others elements of Container are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Length (Container)) - - -- Last cursor has been removed from Container - - and Positions (Container) <= Positions (Container)'Old); - - procedure Union (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Big (Length (Source)) - - -- Elements already in Target are still in Target - - and Model (Target)'Old <= Model (Target) - - -- Elements of Source are included in Target - - and Model (Source) <= Model (Target) - - -- Elements of Target come from either Source or Target - - and - M.Included_In_Union - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) - and - E_Elements_Included - (Elements (Source), - Model (Target)'Old, - Elements (Source), - Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target)'Old, - E_Right => Elements (Target), - P_Left => Positions (Target)'Old, - P_Right => Positions (Target)); - - function Union (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Union'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - + Big (Length (Right)) - - -- Elements of Left and Right are in the result of Union - - and Model (Left) <= Model (Union'Result) - and Model (Right) <= Model (Union'Result) - - -- Elements of the result of union come from either Left or Right - - and - M.Included_In_Union - (Model (Union'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Union'Result), - Model (Left), - Elements (Left), - Elements (Right)) - and - E_Elements_Included - (Elements (Left), Model (Left), Elements (Union'Result)) - and - E_Elements_Included - (Elements (Right), - Model (Left), - Elements (Right), - Elements (Union'Result)); - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are in Source - - and Model (Target) <= Model (Source) - - -- Elements both in Source and Target are in the intersection - - and - M.Includes_Intersection - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and - E_Elements_Included - (Elements (Target)'Old, Model (Source), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Intersection (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Intersection'Result)) = - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements in the result of Intersection are in Left and Right - - and Model (Intersection'Result) <= Model (Left) - and Model (Intersection'Result) <= Model (Right) - - -- Elements both in Left and Right are in the result of Intersection - - and - M.Includes_Intersection - (Model (Intersection'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from Left - - and - E_Elements_Included - (Elements (Intersection'Result), Elements (Left)) - and - E_Elements_Included - (Elements (Left), Model (Right), Elements (Intersection'Result)); - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set) with - Global => null, - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are not in Source - - and M.No_Overlap (Model (Target), Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and - M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Difference (Left, Right : Set) return Set with - Global => null, - Post => - Big (Length (Difference'Result)) = Big (Length (Left)) - - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements of the result of Difference are in Left - - and Model (Difference'Result) <= Model (Left) - - -- Elements of the result of Difference are in Right - - and M.No_Overlap (Model (Difference'Result), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and - M.Included_In_Union - (Model (Left), Model (Difference'Result), Model (Right)) - - -- Actual value of elements come from Left - - and - E_Elements_Included (Elements (Difference'Result), Elements (Left)) - and - E_Elements_Included - (Elements (Left), - Model (Difference'Result), - Elements (Difference'Result)); - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target) + Length (Target and Source), - Post => - Big (Length (Target)) = Big (Length (Target)'Old) - - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Big (Length (Source)) - - -- Elements of the difference were not both in Source and in Target - - and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and - M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Elements in Source but not in Target are in the difference - - and - M.Included_In_Union - (Model (Source), Model (Target), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - and - E_Elements_Included - (Elements (Source), Model (Target), Elements (Target)); - - function Symmetric_Difference (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Big (Length (Symmetric_Difference'Result)) = Big (Length (Left)) - - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Big (Length (Right)) - - -- Elements of the difference were not both in Left and Right - - and - M.Not_In_Both - (Model (Symmetric_Difference'Result), Model (Left), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and - M.Included_In_Union - (Model (Left), Model (Symmetric_Difference'Result), Model (Right)) - - -- Elements in Right but not in Left are in the difference - - and - M.Included_In_Union - (Model (Right), Model (Symmetric_Difference'Result), Model (Left)) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Symmetric_Difference'Result), - Model (Left), - Elements (Left), - Elements (Right)) - and - E_Elements_Included - (Elements (Left), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)) - and - E_Elements_Included - (Elements (Right), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)); - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean with - Global => null, - Post => - Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with - Global => null, - Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); - - function First (Container : Set) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : Set) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = E.Get (Elements (Container), 1) - and E_Smaller_Than_Range - (Elements (Container), - 2, - Length (Container), - First_Element'Result); - - function Last (Container : Set) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : Set) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = E.Get (Elements (Container), Length (Container)) - and E_Bigger_Than_Range - (Elements (Container), - 1, - Length (Container) - 1, - Last_Element'Result); - - function Next (Container : Set; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : Set; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : Set; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : Set; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Item) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Item) - - -- The element designated by the result of Find is Item - - and Equivalent_Elements - (Element (Container, Find'Result), Item)); - - function Floor (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Item < First_Element (Container) => - Floor'Result = No_Element, - others => - Has_Element (Container, Floor'Result) - and - not (Item < E.Get (Elements (Container), - P.Get (Positions (Container), Floor'Result))) - and E_Is_Find - (Elements (Container), - Item, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Last_Element (Container) < Item => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and - not (E.Get (Elements (Container), - P.Get (Positions (Container), Ceiling'Result)) < - Item) - and E_Is_Find - (Elements (Container), - Item, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Set; Item : Element_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Set; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys with SPARK_Mode is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean with - Global => null, - Post => - Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); - - package Formal_Model with Ghost is - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => - Generic_Keys.Key (E.Get (Container, I)) < Key); - pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => - Key < Generic_Keys.Key (E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); - - function E_Is_Find - (Container : E.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= E.Length (Container), - Post => - E_Is_Find'Result = - - ((if Position > 0 then - E_Bigger_Than_Range (Container, 1, Position - 1, Key)) - - and (if Position < E.Length (Container) then - E_Smaller_Than_Range - (Container, - Position + 1, - E.Length (Container), - Key))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); - - function Find - (Container : E.Sequence; - Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Keys - (Key, Generic_Keys.Key (E.Get (Container, Find'Result))) - and E_Is_Find (Container, Key, Find'Result)); - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - with - Global => null, - Post => - M_Included_Except'Result = - (for all E of Left => - Contains (Right, E) - or Equivalent_Keys (Generic_Keys.Key (E), Key)); - end Formal_Model; - use Formal_Model; - - function Key (Container : Set; Position : Cursor) return Key_Type with - Global => null, - Post => Key'Result = Key (Element (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element (Container : Set; Key : Key_Type) return Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Element'Result = Element (Container, Find (Container, Key)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - - -- Key now maps to New_Item - - and Element (Container, Key) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Find (Container, Key)) - and Positions (Container) = Positions (Container)'Old; - - procedure Exclude (Container : in out Set; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The elements of Container located before Key are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Key)'Old - 1) - - -- The elements located after Key are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Key)'Old)); - - procedure Delete (Container : in out Set; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The elements of Container located before Key are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Key)'Old - 1) - - -- The elements located after Key are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Key)'Old); - - function Find (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - ((for all E of Model (Container) => - not Equivalent_Keys (Key, Generic_Keys.Key (E))) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Key) - - -- The element designated by the result of Find is Key - - and Equivalent_Keys - (Generic_Keys.Key (Element (Container, Find'Result)), Key)); - - function Floor (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 - or else Key < Generic_Keys.Key (First_Element (Container)) => - Floor'Result = No_Element, - others => - Has_Element (Container, Floor'Result) - and - not (Key < - Generic_Keys.Key - (E.Get (Elements (Container), - P.Get (Positions (Container), Floor'Result)))) - and E_Is_Find - (Elements (Container), - Key, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 - or else Generic_Keys.Key (Last_Element (Container)) < Key => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and - not (Generic_Keys.Key - (E.Get (Elements (Container), - P.Get (Positions (Container), Ceiling'Result))) - < Key) - and E_Is_Find - (Elements (Container), - Key, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Set; Key : Key_Type) return Boolean with - Global => null, - Post => - Contains'Result = - (for some E of Model (Container) => - Equivalent_Keys (Key, Generic_Keys.Key (E))); - - end Generic_Keys; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type is record - Has_Element : Boolean := False; - Parent : Count_Type := 0; - Left : Count_Type := 0; - Right : Count_Type := 0; - Color : Red_Black_Trees.Color_Type; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Set (Capacity : Count_Type) is record - Content : Tree_Types.Tree_Type (Capacity); - end record; - - use Red_Black_Trees; +package Ada.Containers.Formal_Ordered_Sets with SPARK_Mode is - Empty_Set : constant Set := (Capacity => 0, others => <>); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb deleted file mode 100644 index c921184..0000000 --- a/gcc/ada/libgnat/a-cofove.adb +++ /dev/null @@ -1,1311 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2022, 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/>. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Vectors with - SPARK_Mode => Off -is - - subtype Int is Long_Long_Integer; - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - --------- - -- "=" -- - --------- - - function "=" (Left : Vector; Right : Vector) return Boolean is - begin - if Left'Address = Right'Address then - return True; - end if; - - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Length (Left) loop - if Left.Elements (J) /= Right.Elements (J) then - return False; - end if; - end loop; - - return True; - end "="; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item); - end Append; - - procedure Append (Container : in out Vector; New_Item : Element_Type) is - begin - Append (Container, New_Item, 1); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Capacity_Range is - begin - return Container.Capacity; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - Container.Last := No_Index; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - return Container.Elements (To_Array_Index (Index))'Access; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - is - LS : constant Capacity_Range := Length (Source); - C : Capacity_Range; - - begin - if Capacity = 0 then - C := LS; - elsif Capacity >= LS then - C := Capacity; - else - raise Capacity_Error with "Capacity too small"; - end if; - - return Target : Vector (C) do - Target.Elements (1 .. LS) := Source.Elements (1 .. LS); - Target.Last := Source.Last; - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Vector; Index : Extended_Index) is - begin - Delete (Container, Index, 1); - end Delete; - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - is - Old_Last : constant Index_Type'Base := Container.Last; - Old_Len : constant Count_Type := Length (Container); - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - Off : Count_Type'Base; -- Index expressed as offset from IT'First - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - if Count = 0 then - return; - end if; - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements aren't being deleted (the requested count was - -- less than the available count), so we must slide them down to Index. - -- We first calculate the index values of the respective array slices, - -- using the wider of Index_Type'Base and Count_Type'Base as the type - -- for intermediate calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Off := Count_Type'Base (Index - Index_Type'First); - New_Last := Old_Last - Index_Type'Base (Count); - else - Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - end if; - - -- The array index values for each slice have already been determined, - -- so we just slide down to Index the elements that weren't deleted. - - declare - EA : Elements_Array renames Container.Elements; - Idx : constant Count_Type := EA'First + Off; - begin - EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); - Container.Last := New_Last; - end; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Vector) is - begin - Delete_First (Container, 1); - end Delete_First; - - procedure Delete_First (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Vector) is - begin - Delete_Last (Container, 1); - end Delete_Last; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - end if; - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Length (Container) then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - begin - return Container.Elements (I); - end; - end Element; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - K : Count_Type; - Last : constant Extended_Index := Last_Index (Container); - - begin - K := Capacity_Range (Int (Index) - Int (No_Index)); - for Indx in Index .. Last loop - if Container.Elements (K) = Item then - return Indx; - end if; - - K := K + 1; - end loop; - - return No_Index; - end Find_Index; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Container.Elements (1); - end if; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - Elem : Element_Type; - - begin - for Index in Index_Type'First .. M.Last (Container) loop - Elem := Element (Container, Index); - - if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) - and then - not M.Contains (Right, Index_Type'First, M.Last (Right), Elem) - then - return False; - end if; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Extended_Index := R_Fst - 1; - - begin - while not Found and J < R_Lst loop - J := J + 1; - if Element (Left, I) = Element (Right, J) then - Found := True; - end if; - end loop; - - if not Found then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_Included; - - ------------------------- - -- M_Elements_Reversed -- - ------------------------- - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - is - L : constant Index_Type := M.Last (Left); - - begin - if L /= M.Last (Right) then - return False; - end if; - - for I in Index_Type'First .. L loop - if Element (Left, I) /= Element (Right, L - I + 1) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Reversed; - - ------------------------ - -- M_Elements_Swapped -- - ------------------------ - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - is - begin - if M.Length (Left) /= M.Length (Right) - or else Element (Left, X) /= Element (Right, Y) - or else Element (Left, Y) /= Element (Right, X) - then - return False; - end if; - - for I in Index_Type'First .. M.Last (Left) loop - if I /= X and then I /= Y - and then Element (Left, I) /= Element (Right, I) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Swapped; - - ----------- - -- Model -- - ----------- - - function Model (Container : Vector) return M.Sequence is - R : M.Sequence; - - begin - for Position in 1 .. Length (Container) loop - R := M.Add (R, Container.Elements (Position)); - end loop; - - return R; - end Model; - - end Formal_Model; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting with SPARK_Mode => Off is - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Elements_Sorted -- - ----------------------- - - function M_Elements_Sorted (Container : M.Sequence) return Boolean is - begin - if M.Length (Container) = 0 then - return True; - end if; - - declare - E1 : Element_Type := Element (Container, Index_Type'First); - - begin - for I in Index_Type'First + 1 .. M.Last (Container) loop - declare - E2 : constant Element_Type := Element (Container, I); - - begin - if E2 < E1 then - return False; - end if; - - E1 := E2; - end; - end loop; - end; - - return True; - end M_Elements_Sorted; - - end Formal_Model; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - L : constant Capacity_Range := Length (Container); - - begin - for J in 1 .. L - 1 loop - if Container.Elements (J + 1) < - Container.Elements (J) - then - return False; - end if; - end loop; - - return True; - end Is_Sorted; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - procedure Sort is - new Generic_Array_Sort - (Index_Type => Array_Index, - Element_Type => Element_Type, - Array_Type => Elements_Array, - "<" => "<"); - - Len : constant Capacity_Range := Length (Container); - - begin - if Container.Last <= Index_Type'First then - return; - else - Sort (Container.Elements (1 .. Len)); - end if; - end Sort; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out Vector; Source : in out Vector) is - I : Count_Type; - J : Count_Type; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Length (Source) = 0 then - return; - end if; - - if Length (Target) = 0 then - Move (Target => Target, Source => Source); - return; - end if; - - I := Length (Target); - - declare - New_Length : constant Count_Type := I + Length (Source); - - begin - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Target.Last := No_Index + Index_Type'Base (New_Length); - - else - Target.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end; - - declare - TA : Elements_Array renames Target.Elements; - SA : Elements_Array renames Source.Elements; - - begin - J := Length (Target); - while Length (Source) /= 0 loop - if I = 0 then - TA (1 .. J) := SA (1 .. Length (Source)); - Source.Last := No_Index; - exit; - end if; - - if SA (Length (Source)) < TA (I) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Length (Source)); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - end Generic_Sorting; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - begin - return Position in First_Index (Container) .. Last_Index (Container); - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - is - begin - Insert (Container, Before, New_Item, 1); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - is - J : Count_Type'Base; -- scratch - - begin - -- Use Insert_Space to create the "hole" (the destination slice) - - Insert_Space (Container, Before, Count); - - J := To_Array_Index (Before); - - Container.Elements (J .. J - 1 + Count) := [others => New_Item]; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - B : Count_Type; -- index Before converted to Count_Type - - begin - if Container'Address = New_Item'Address then - raise Program_Error with - "Container and New_Item denote same container"; - end if; - - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - B := To_Array_Index (Before); - - Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Length (Container); - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before - 1 > Container.Last - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, so we - -- simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note that the value cannot be simply added because the result may - -- overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - - -- Raise Capacity_Error if the new length exceeds the container's - -- capacity. - - elsif New_Length > Container.Capacity then - raise Capacity_Error with "New length is larger than capacity"; - end if; - - J := To_Array_Index (Before); - - declare - EA : Elements_Array renames Container.Elements; - - begin - if Before <= Container.Last then - - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. - - EA (J + Count .. New_Length) := EA (J .. Old_Length); - end if; - end; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Last_Index (Container) < Index_Type'First; - end Is_Empty; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Container.Elements (Length (Container)); - end if; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Capacity_Range is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Capacity_Range (N); - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Vector; Source : in out Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - Clear (Source); - end Move; - - ------------ - -- Prepend -- - ------------ - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) is - begin - Prepend (Container, New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - Container.Elements (I) := New_Item; - end; - end Replace_Element; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - return Container.Elements (To_Array_Index (Index))'Access; - end Reference; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - is - begin - if Capacity > Container.Capacity then - raise Capacity_Error with "Capacity is out of range"; - end if; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Length (Container) <= 1 then - return; - end if; - - declare - I, J : Capacity_Range; - E : Elements_Array renames - Container.Elements (1 .. Length (Container)); - - begin - I := 1; - J := Length (Container); - while I < J loop - declare - EI : constant Element_Type := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - Last : Index_Type'Base; - K : Count_Type'Base; - - begin - if Index > Last_Index (Container) then - Last := Last_Index (Container); - else - Last := Index; - end if; - - K := Capacity_Range (Int (Last) - Int (No_Index)); - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements (K) = Item then - return Indx; - end if; - - K := K - 1; - end loop; - - return No_Index; - end Reverse_Find_Index; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - is - begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - declare - II : constant Int'Base := Int (I) - Int (No_Index); - JJ : constant Int'Base := Int (J) - Int (No_Index); - - EI : Element_Type renames Container.Elements (Capacity_Range (II)); - EJ : Element_Type renames Container.Elements (Capacity_Range (JJ)); - - EI_Copy : constant Element_Type := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - -------------------- - -- To_Array_Index -- - -------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is - Offset : Count_Type'Base; - - begin - -- We know that - -- Index >= Index_Type'First - -- hence we also know that - -- Index - Index_Type'First >= 0 - - -- The issue is that even though 0 is guaranteed to be a value in - -- the type Index_Type'Base, there's no guarantee that the difference - -- is a value in that type. To prevent overflow we use the wider - -- of Count_Type'Base and Index_Type'Base to perform intermediate - -- calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Offset := Count_Type'Base (Index - Index_Type'First); - - else - Offset := - Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - end if; - - -- The array index subtype for all container element arrays always - -- starts with 1. - - return 1 + Offset; - end To_Array_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return - (Capacity => Length, - Last => Last, - Elements => [others => New_Item]); - end; - end To_Vector; - -end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads index 6413375..fb9301f 100644 --- a/gcc/ada/libgnat/a-cofove.ads +++ b/gcc/ada/libgnat/a-cofove.ads @@ -29,954 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ --- This spec is derived from package Ada.Containers.Bounded_Vectors in the Ada --- 2012 RM. The modifications are meant to facilitate formal proofs by making --- it easier to express properties, and by making the specification of this --- unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - -with Ada.Containers.Functional_Vectors; - generic - type Index_Type is range <>; - type Element_Type is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Vectors with - SPARK_Mode -is - pragma Annotate (GNATprove, Always_Return, Formal_Vectors); - - -- Contracts in this unit are meant for analysis only, not for run-time - -- checking. - - pragma Assertion_Policy (Pre => Ignore); - pragma Assertion_Policy (Post => Ignore); - pragma Assertion_Policy (Contract_Cases => Ignore); - pragma Annotate (CodePeer, Skip_Analysis); - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then - 0 - elsif Index_Type'Last < -1 - or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then - Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else - Count_Type'Last); - -- Maximal capacity of any vector. It is the minimum of the size of the - -- index range and the last possible Count_Type. - - subtype Capacity_Range is Count_Type range 0 .. Last_Count; - - type Vector (Capacity : Capacity_Range) is private with - Default_Initial_Condition => Is_Empty (Vector), - Iterable => (First => Iter_First, - Has_Element => Iter_Has_Element, - Next => Iter_Next, - Element => Element); - - function Length (Container : Vector) return Capacity_Range with - Global => null, - Post => Length'Result <= Capacity (Container); - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Index_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for some J in Index_Type'First .. M.Last (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in Index_Type'First .. M.Last (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in Index_Type'First .. M.Last (Left) => - Element (Left, I) = - Element (Right, M.Last (Left) - I + 1)) - and (for all I in Index_Type'First .. M.Last (Right) => - Element (Right, I) = - Element (Left, M.Last (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Last (Left) and Y <= M.Last (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - function Model (Container : Vector) return M.Sequence with - -- The high-level model of a vector is a sequence of elements. The - -- sequence really is similar to the vector itself. However, it is not - -- limited which allows usage of 'Old and 'Loop_Entry attributes. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); - - function Element - (S : M.Sequence; - I : Index_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function Empty_Vector return Vector with - Global => null, - Post => Length (Empty_Vector'Result) = 0; - - function "=" (Left, Right : Vector) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - with - Global => null, - Post => - Formal_Vectors.Length (To_Vector'Result) = Length - and M.Constant_Range - (Container => Model (To_Vector'Result), - Fst => Index_Type'First, - Lst => Last_Index (To_Vector'Result), - Item => New_Item); - - function Capacity (Container : Vector) return Capacity_Range with - Global => null, - Post => - Capacity'Result = Container.Capacity; - pragma Annotate (GNATprove, Inline_For_Proof, Capacity); - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => Model (Container) = Model (Container)'Old; - - function Is_Empty (Container : Vector) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Vector) with - Global => null, - Post => Length (Container) = 0; - - procedure Assign (Target : in out Vector; Source : Vector) with - Global => null, - Pre => Length (Source) <= Target.Capacity, - Post => Model (Target) = Model (Source); - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - with - Global => null, - Pre => (Capacity = 0 or Length (Source) <= Capacity), - Post => - Model (Copy'Result) = Model (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Length (Source) - else - Copy'Result.Capacity = Capacity); - - procedure Move (Target : in out Vector; Source : in out Vector) - with - Global => null, - Pre => Length (Source) <= Capacity (Target), - Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; - - function Element - (Container : Vector; - Index : Extended_Index) return Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => Element'Result = Element (Model (Container), Index); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - - -- Container now has New_Item at index Index - - and Element (Model (Container), Index) = New_Item - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container)'Old, - Right => Model (Container), - Position => Index); - - function At_End (E : access constant Vector) return access constant Vector - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function At_End - (E : access constant Element_Type) return access constant Element_Type - is (E) - with Ghost, - Annotate => (GNATprove, At_End_Borrow); - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return not null access constant Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Constant_Reference'Result.all = Element (Model (Container), Index); - - function Reference - (Container : not null access Vector; - Index : Index_Type) return not null access Element_Type - with - Global => null, - Pre => - Index in First_Index (Container.all) .. Last_Index (Container.all), - Post => - Length (Container.all) = Length (At_End (Container).all) - - -- Container will have Result.all at index Index - - and At_End (Reference'Result).all = - Element (Model (At_End (Container).all), Index) - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container.all), - Right => Model (At_End (Container).all), - Position => Index); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item) - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Elements of New_Item are inserted at position Before - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => Count_Type (Before - Index_Type'First))) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Capacity (Container) - and then (Before in Index_Type'First .. Last_Index (Container) + 1), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Container now has New_Item at index Before - - and Element (Model (Container), Before) = New_Item - - -- Elements located after Before in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Count - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- New_Item is inserted Count times at position Before - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Before, - Lst => Before + Index_Type'Base (Count - 1), - Item => New_Item)) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Prepend (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements of New_Item are inserted at the beginning of Container - - and M.Range_Equal - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item)) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Container now has New_Item at Index_Type'First - - and Element (Model (Container), Index_Type'First) = New_Item - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- New_Item is inserted Count times at the beginning of Container - - and M.Constant_Range - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Index_Type'First + Index_Type'Base (Count - 1), - Item => New_Item) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Append (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Elements of New_Item are inserted at the end of Container - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => - Count_Type - (Last_Index (Container)'Old - Index_Type'First + 1))); - - procedure Append (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements of Container are preserved - - and Model (Container)'Old < Model (Container) - - -- Container now has New_Item at the end of Container - - and Element - (Model (Container), Last_Index (Container)'Old + 1) = New_Item; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- New_Item is inserted Count times at the end of Container - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Last_Index (Container)'Old + 1, - Lst => - Last_Index (Container)'Old + Index_Type'Base (Count), - Item => New_Item)); - - procedure Delete (Container : in out Vector; Index : Extended_Index) with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements located before Index in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1) - - -- Elements located after Index in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - with - Global => null, - Pre => - Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- The elements of Container located before Index are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => - Length (Container) = Count_Type (Index - Index_Type'First), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_First (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete_First (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_Last (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are preserved - - and Model (Container) < Model (Container)'Old; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old); - - procedure Reverse_Elements (Container : in out Vector) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - with - Global => null, - Pre => - I in First_Index (Container) .. Last_Index (Container) - and then J in First_Index (Container) .. Last_Index (Container), - Post => - M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); - - function First_Index (Container : Vector) return Index_Type with - Global => null, - Post => First_Index'Result = Index_Type'First; - pragma Annotate (GNATprove, Inline_For_Proof, First_Index); - - function First_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = Element (Model (Container), Index_Type'First); - pragma Annotate (GNATprove, Inline_For_Proof, First_Element); - - function Last_Index (Container : Vector) return Extended_Index with - Global => null, - Post => Last_Index'Result = M.Last (Model (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); - - function Last_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = - Element (Model (Container), Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container after Index, Find_Index - -- returns No_Index. - - (Index > Last_Index (Container) - or else not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Last_Index (Container), - Item => Item) - => - Find_Index'Result = No_Index, - - -- Otherwise, Find_Index returns a valid index greater than Index - - others => - Find_Index'Result in Index .. Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Find_Index'Result) = Item - - -- It is the first occurrence of Item after Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Find_Index'Result - 1, - Item => Item)); - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container before Index, - -- Reverse_Find_Index returns No_Index. - - (not M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => (if Index <= Last_Index (Container) then Index - else Last_Index (Container)), - Item => Item) - => - Reverse_Find_Index'Result = No_Index, - - -- Otherwise, Reverse_Find_Index returns a valid index smaller than - -- Index - - others => - Reverse_Find_Index'Result in Index_Type'First .. Index - and Reverse_Find_Index'Result <= Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Reverse_Find_Index'Result) = Item - - -- It is the last occurrence of Item before Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Reverse_Find_Index'Result + 1, - Lst => - (if Index <= Last_Index (Container) then - Index - else - Last_Index (Container)), - Item => Item)); - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = - M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container), - Item => Item); - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for all J in I .. M.Last (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : Vector) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out Vector) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Last_Index (Container), - Right => Model (Container), - R_Lst => Last_Index (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Last_Index (Container), - Right => Model (Container)'Old, - R_Lst => Last_Index (Container)); - - procedure Merge (Target : in out Vector; Source : in out Vector) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Capacity (Target) - Length (Target), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Last_Index (Target)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Last_Index (Source)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - function Iter_First (Container : Vector) return Extended_Index with - Global => null; - - function Iter_Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Iter_Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); - - function Iter_Next - (Container : Vector; - Position : Extended_Index) return Extended_Index - with - Global => null, - Pre => Iter_Has_Element (Container, Position); - -private - pragma SPARK_Mode (Off); - - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Replace_Element); - pragma Inline (Contains); - - subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; - type Elements_Array is array (Array_Index range <>) of aliased Element_Type; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Vector (Capacity : Capacity_Range) is record - Last : Extended_Index := No_Index; - Elements : Elements_Array (1 .. Capacity); - end record; - - function Empty_Vector return Vector is - ((Capacity => 0, others => <>)); - - function Iter_First (Container : Vector) return Extended_Index is - (Index_Type'First); - - function Iter_Next - (Container : Vector; - Position : Extended_Index) return Extended_Index - is - (if Position = Extended_Index'Last then - Extended_Index'First - else - Extended_Index'Succ (Position)); +package Ada.Containers.Formal_Vectors with SPARK_Mode is - function Iter_Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - (Position in Index_Type'First .. Container.Last); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb deleted file mode 100644 index 68cf2ae..0000000 --- a/gcc/ada/libgnat/a-cofuba.adb +++ /dev/null @@ -1,432 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_BASE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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/>. -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -with Ada.Unchecked_Deallocation; - -package body Ada.Containers.Functional_Base with SPARK_Mode => Off is - - function To_Count (Idx : Extended_Index) return Count_Type is - (Count_Type - (Extended_Index'Pos (Idx) - - Extended_Index'Pos (Extended_Index'First))); - - function To_Index (Position : Count_Type) return Extended_Index is - (Extended_Index'Val - (Position + Extended_Index'Pos (Extended_Index'First))); - -- Conversion functions between Index_Type and Count_Type - - function Find (C : Container; E : access Element_Type) return Count_Type; - -- Search a container C for an element equal to E.all, returning the - -- position in the underlying array. - - procedure Resize (Base : Array_Base_Access); - -- Resize the underlying array if needed so that it can contain one more - -- element. - - function Elements (C : Container) return Element_Array_Access is - (C.Controlled_Base.Base.Elements) - with - Global => null, - Pre => - C.Controlled_Base.Base /= null - and then C.Controlled_Base.Base.Elements /= null; - - function Get - (C_E : Element_Array_Access; - I : Count_Type) - return Element_Access - is - (C_E (I).Ref.E_Access) - with - Global => null, - Pre => C_E /= null and then C_E (I).Ref /= null; - - --------- - -- "=" -- - --------- - - function "=" (C1 : Container; C2 : Container) return Boolean is - begin - if C1.Length /= C2.Length then - return False; - end if; - for I in 1 .. C1.Length loop - if Get (Elements (C1), I).all /= Get (Elements (C2), I).all then - return False; - end if; - end loop; - - return True; - end "="; - - ---------- - -- "<=" -- - ---------- - - function "<=" (C1 : Container; C2 : Container) return Boolean is - begin - for I in 1 .. C1.Length loop - if Find (C2, Get (Elements (C1), I)) = 0 then - return False; - end if; - end loop; - - return True; - end "<="; - - --------- - -- Add -- - --------- - - function Add - (C : Container; - I : Index_Type; - E : Element_Type) return Container - is - C_B : Array_Base_Access renames C.Controlled_Base.Base; - begin - if To_Count (I) = C.Length + 1 and then C.Length = C_B.Max_Length then - Resize (C_B); - C_B.Max_Length := C_B.Max_Length + 1; - C_B.Elements (C_B.Max_Length) := Element_Init (E); - - return Container'(Length => C_B.Max_Length, - Controlled_Base => C.Controlled_Base); - else - declare - A : constant Array_Base_Controlled_Access := - Content_Init (C.Length); - P : Count_Type := 0; - begin - A.Base.Max_Length := C.Length + 1; - for J in 1 .. C.Length + 1 loop - if J /= To_Count (I) then - P := P + 1; - A.Base.Elements (J) := C_B.Elements (P); - else - A.Base.Elements (J) := Element_Init (E); - end if; - end loop; - - return Container'(Length => A.Base.Max_Length, - Controlled_Base => A); - end; - end if; - end Add; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Controlled_Base : in out Array_Base_Controlled_Access) is - C_B : Array_Base_Access renames Controlled_Base.Base; - begin - if C_B /= null then - C_B.Reference_Count := C_B.Reference_Count + 1; - end if; - end Adjust; - - procedure Adjust (Ctrl_E : in out Controlled_Element_Access) is - begin - if Ctrl_E.Ref /= null then - Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count + 1; - end if; - end Adjust; - - ------------------ - -- Content_Init -- - ------------------ - - function Content_Init - (L : Count_Type := 0) return Array_Base_Controlled_Access - is - Max_Init : constant Count_Type := 100; - Size : constant Count_Type := - (if L < Count_Type'Last - Max_Init then L + Max_Init - else Count_Type'Last); - - -- The Access in the array will be initialized to null - - Elements : constant Element_Array_Access := - new Element_Array'(1 .. Size => <>); - B : constant Array_Base_Access := - new Array_Base'(Reference_Count => 1, - Max_Length => 0, - Elements => Elements); - begin - return (Ada.Finalization.Controlled with Base => B); - end Content_Init; - - ------------------ - -- Element_Init -- - ------------------ - - function Element_Init (E : Element_Type) return Controlled_Element_Access - is - Refcounted_E : constant Refcounted_Element_Access := - new Refcounted_Element'(Reference_Count => 1, - E_Access => new Element_Type'(E)); - begin - return (Ada.Finalization.Controlled with Ref => Refcounted_E); - end Element_Init; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Controlled_Base : in out Array_Base_Controlled_Access) - is - procedure Unchecked_Free_Base is new Ada.Unchecked_Deallocation - (Object => Array_Base, - Name => Array_Base_Access); - procedure Unchecked_Free_Array is new Ada.Unchecked_Deallocation - (Object => Element_Array, - Name => Element_Array_Access); - - C_B : Array_Base_Access renames Controlled_Base.Base; - begin - if C_B /= null then - C_B.Reference_Count := C_B.Reference_Count - 1; - if C_B.Reference_Count = 0 then - Unchecked_Free_Array (Controlled_Base.Base.Elements); - Unchecked_Free_Base (Controlled_Base.Base); - end if; - C_B := null; - end if; - end Finalize; - - procedure Finalize (Ctrl_E : in out Controlled_Element_Access) is - procedure Unchecked_Free_Ref is new Ada.Unchecked_Deallocation - (Object => Refcounted_Element, - Name => Refcounted_Element_Access); - - procedure Unchecked_Free_Element is new Ada.Unchecked_Deallocation - (Object => Element_Type, - Name => Element_Access); - - begin - if Ctrl_E.Ref /= null then - Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count - 1; - if Ctrl_E.Ref.Reference_Count = 0 then - Unchecked_Free_Element (Ctrl_E.Ref.E_Access); - Unchecked_Free_Ref (Ctrl_E.Ref); - end if; - Ctrl_E.Ref := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (C : Container; E : access Element_Type) return Count_Type is - begin - for I in 1 .. C.Length loop - if Get (Elements (C), I).all = E.all then - return I; - end if; - end loop; - - return 0; - end Find; - - function Find (C : Container; E : Element_Type) return Extended_Index is - (To_Index (Find (C, E'Unrestricted_Access))); - - --------- - -- Get -- - --------- - - function Get (C : Container; I : Index_Type) return Element_Type is - (Get (Elements (C), To_Count (I)).all); - - ------------------ - -- Intersection -- - ------------------ - - function Intersection (C1 : Container; C2 : Container) return Container is - L : constant Count_Type := Num_Overlaps (C1, C2); - A : constant Array_Base_Controlled_Access := Content_Init (L); - P : Count_Type := 0; - - begin - A.Base.Max_Length := L; - for I in 1 .. C1.Length loop - if Find (C2, Get (Elements (C1), I)) > 0 then - P := P + 1; - A.Base.Elements (P) := Elements (C1) (I); - end if; - end loop; - - return Container'(Length => P, Controlled_Base => A); - end Intersection; - - ------------ - -- Length -- - ------------ - - function Length (C : Container) return Count_Type is (C.Length); - --------------------- - -- Num_Overlaps -- - --------------------- - - function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is - P : Count_Type := 0; - - begin - for I in 1 .. C1.Length loop - if Find (C2, Get (Elements (C1), I)) > 0 then - P := P + 1; - end if; - end loop; - - return P; - end Num_Overlaps; - - ------------ - -- Remove -- - ------------ - - function Remove (C : Container; I : Index_Type) return Container is - begin - if To_Count (I) = C.Length then - return Container'(Length => C.Length - 1, - Controlled_Base => C.Controlled_Base); - else - declare - A : constant Array_Base_Controlled_Access - := Content_Init (C.Length - 1); - P : Count_Type := 0; - begin - A.Base.Max_Length := C.Length - 1; - for J in 1 .. C.Length loop - if J /= To_Count (I) then - P := P + 1; - A.Base.Elements (P) := Elements (C) (J); - end if; - end loop; - - return Container'(Length => C.Length - 1, Controlled_Base => A); - end; - end if; - end Remove; - - ------------ - -- Resize -- - ------------ - - procedure Resize (Base : Array_Base_Access) is - begin - if Base.Max_Length < Base.Elements'Length then - return; - end if; - - pragma Assert (Base.Max_Length = Base.Elements'Length); - - if Base.Max_Length = Count_Type'Last then - raise Constraint_Error; - end if; - - declare - procedure Finalize is new Ada.Unchecked_Deallocation - (Object => Element_Array, - Name => Element_Array_Access_Base); - - New_Length : constant Positive_Count_Type := - (if Base.Max_Length > Count_Type'Last / 2 then Count_Type'Last - else 2 * Base.Max_Length); - Elements : constant Element_Array_Access := - new Element_Array (1 .. New_Length); - Old_Elmts : Element_Array_Access_Base := Base.Elements; - begin - Elements (1 .. Base.Max_Length) := Base.Elements.all; - Base.Elements := Elements; - Finalize (Old_Elmts); - end; - end Resize; - - --------- - -- Set -- - --------- - - function Set - (C : Container; - I : Index_Type; - E : Element_Type) return Container - is - Result : constant Container := - Container'(Length => C.Length, - Controlled_Base => Content_Init (C.Length)); - R_Base : Array_Base_Access renames Result.Controlled_Base.Base; - - begin - R_Base.Max_Length := C.Length; - R_Base.Elements (1 .. C.Length) := Elements (C) (1 .. C.Length); - R_Base.Elements (To_Count (I)) := Element_Init (E); - return Result; - end Set; - - ----------- - -- Union -- - ----------- - - function Union (C1 : Container; C2 : Container) return Container is - N : constant Count_Type := Num_Overlaps (C1, C2); - - begin - -- if C2 is completely included in C1 then return C1 - - if N = Length (C2) then - return C1; - end if; - - -- else loop through C2 to find the remaining elements - - declare - L : constant Count_Type := Length (C1) - N + Length (C2); - A : constant Array_Base_Controlled_Access := Content_Init (L); - P : Count_Type := Length (C1); - begin - A.Base.Max_Length := L; - A.Base.Elements (1 .. C1.Length) := Elements (C1) (1 .. C1.Length); - for I in 1 .. C2.Length loop - if Find (C1, Get (Elements (C2), I)) = 0 then - P := P + 1; - A.Base.Elements (P) := Elements (C2) (I); - end if; - end loop; - - return Container'(Length => L, Controlled_Base => A); - end; - end Union; - -end Ada.Containers.Functional_Base; diff --git a/gcc/ada/libgnat/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads deleted file mode 100644 index 8a99a43..0000000 --- a/gcc/ada/libgnat/a-cofuba.ads +++ /dev/null @@ -1,198 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_BASE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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/>. -- ------------------------------------------------------------------------------- --- Functional containers are neither controlled nor limited. This is safe, as --- no primitives are provided to modify them. --- Memory allocated inside functional containers is never reclaimed. - -pragma Ada_2012; - --- To allow reference counting on the base container - -private with Ada.Finalization; - -private generic - type Index_Type is (<>); - -- To avoid Constraint_Error being raised at run time, Index_Type'Base - -- should have at least one more element at the low end than Index_Type. - - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Functional_Base with SPARK_Mode => Off is - - subtype Extended_Index is Index_Type'Base range - Index_Type'Pred (Index_Type'First) .. Index_Type'Last; - - type Container is private; - - function "=" (C1 : Container; C2 : Container) return Boolean; - -- Return True if C1 and C2 contain the same elements at the same position - - function Length (C : Container) return Count_Type; - -- Number of elements stored in C - - function Get (C : Container; I : Index_Type) return Element_Type; - -- Access to the element at index I in C - - function Set - (C : Container; - I : Index_Type; - E : Element_Type) return Container; - -- Return a new container which is equal to C except for the element at - -- index I, which is set to E. - - function Add - (C : Container; - I : Index_Type; - E : Element_Type) return Container; - -- Return a new container that is C with E inserted at index I - - function Remove (C : Container; I : Index_Type) return Container; - -- Return a new container that is C without the element at index I - - function Find (C : Container; E : Element_Type) return Extended_Index; - -- Return the first index for which the element stored in C is I. If there - -- are no such indexes, return Extended_Index'First. - - -------------------- - -- Set Operations -- - -------------------- - - function "<=" (C1 : Container; C2 : Container) return Boolean; - -- Return True if every element of C1 is in C2 - - function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type; - -- Return the number of elements that are in both C1 and C2 - - function Union (C1 : Container; C2 : Container) return Container; - -- Return a container which is C1 plus all the elements of C2 that are not - -- in C1. - - function Intersection (C1 : Container; C2 : Container) return Container; - -- Return a container which is C1 minus all the elements that are also in - -- C2. - -private - - -- Theoretically, each operation on a functional container implies the - -- creation of a new container i.e. the copy of the array itself and all - -- the elements in it. In the implementation, most of these copies are - -- avoided by sharing between the containers. - -- - -- A container stores its last used index. So, when adding an - -- element at the end of the container, the exact same array can be reused. - -- As a functionnal container cannot be modifed once created, there is no - -- risk of unwanted modifications. - -- - -- _1_2_3_ - -- S : end => [1, 2, 3] - -- | - -- |1|2|3|4|.|.| - -- | - -- Add (S, 4, 4) : end => [1, 2, 3, 4] - -- - -- The elements are also shared between containers as much as possible. For - -- example, when something is added in the middle, the array is changed but - -- the elementes are reused. - -- - -- _1_2_3_4_ - -- S : |1|2|3|4| => [1, 2, 3, 4] - -- | \ \ \ - -- Add (S, 2, 5) : |1|5|2|3|4| => [1, 5, 2, 3, 4] - -- - -- To make this sharing possible, both the elements and the arrays are - -- stored inside dynamically allocated access types which shall be - -- deallocated when they are no longer used. The memory is managed using - -- reference counting both at the array and at the element level. - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - type Reference_Count_Type is new Natural; - - type Element_Access is access all Element_Type; - - type Refcounted_Element is record - Reference_Count : Reference_Count_Type; - E_Access : Element_Access; - end record; - - type Refcounted_Element_Access is access Refcounted_Element; - - type Controlled_Element_Access is new Ada.Finalization.Controlled - with record - Ref : Refcounted_Element_Access := null; - end record; - - function Element_Init (E : Element_Type) return Controlled_Element_Access; - -- Use to initialize a refcounted element - - type Element_Array is - array (Positive_Count_Type range <>) of Controlled_Element_Access; - - type Element_Array_Access_Base is access Element_Array; - - subtype Element_Array_Access is Element_Array_Access_Base; - - type Array_Base is record - Reference_Count : Reference_Count_Type; - Max_Length : Count_Type; - Elements : Element_Array_Access; - end record; - - type Array_Base_Access is access Array_Base; - - type Array_Base_Controlled_Access is new Ada.Finalization.Controlled - with record - Base : Array_Base_Access; - end record; - - overriding procedure Adjust - (Controlled_Base : in out Array_Base_Controlled_Access); - - overriding procedure Finalize - (Controlled_Base : in out Array_Base_Controlled_Access); - - overriding procedure Adjust - (Ctrl_E : in out Controlled_Element_Access); - - overriding procedure Finalize - (Ctrl_E : in out Controlled_Element_Access); - - function Content_Init (L : Count_Type := 0) - return Array_Base_Controlled_Access; - -- Used to initialize the content of an array base with length L - - type Container is record - Length : Count_Type := 0; - Controlled_Base : Array_Base_Controlled_Access := Content_Init; - end record; - -end Ada.Containers.Functional_Base; diff --git a/gcc/ada/libgnat/a-cofuma.adb b/gcc/ada/libgnat/a-cofuma.adb deleted file mode 100644 index f83b4d8..0000000 --- a/gcc/ada/libgnat/a-cofuma.adb +++ /dev/null @@ -1,306 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_MAPS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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/>. -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is - use Key_Containers; - use Element_Containers; - - package Conversions is new Signed_Conversions (Int => Count_Type); - use Conversions; - - --------- - -- "=" -- - --------- - - function "=" (Left : Map; Right : Map) return Boolean is - (Left.Keys <= Right.Keys and Right <= Left); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Map; Right : Map) return Boolean is - I2 : Count_Type; - - begin - for I1 in 1 .. Length (Left.Keys) loop - I2 := Find (Right.Keys, Get (Left.Keys, I1)); - if I2 = 0 - or else Get (Right.Elements, I2) /= Get (Left.Elements, I1) - then - return False; - end if; - end loop; - return True; - end "<="; - - --------- - -- Add -- - --------- - - function Add - (Container : Map; - New_Key : Key_Type; - New_Item : Element_Type) return Map - is - begin - return - (Keys => - Add (Container.Keys, Length (Container.Keys) + 1, New_Key), - Elements => - Add - (Container.Elements, Length (Container.Elements) + 1, New_Item)); - end Add; - - --------------------------- - -- Elements_Equal_Except -- - --------------------------- - - function Elements_Equal_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, New_Key) - and then - (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, J)) - then - return False; - end if; - end; - end loop; - return True; - end Elements_Equal_Except; - - function Elements_Equal_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, X) - and then not Equivalent_Keys (K, Y) - and then - (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, J)) - then - return False; - end if; - end; - end loop; - return True; - end Elements_Equal_Except; - - --------------- - -- Empty_Map -- - --------------- - - function Empty_Map return Map is - ((others => <>)); - - --------- - -- Get -- - --------- - - function Get (Container : Map; Key : Key_Type) return Element_Type is - begin - return Get (Container.Elements, Find (Container.Keys, Key)); - end Get; - - ------------- - -- Has_Key -- - ------------- - - function Has_Key (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container.Keys, Key) > 0; - end Has_Key; - - ----------------- - -- Has_Witness -- - ----------------- - - function Has_Witness - (Container : Map; - Witness : Count_Type) return Boolean - is - (Witness in 1 .. Length (Container.Keys)); - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container.Keys) = 0; - end Is_Empty; - - ------------------- - -- Keys_Included -- - ------------------- - - function Keys_Included (Left : Map; Right : Map) return Boolean is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if Find (Right.Keys, K) = 0 then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included; - - -------------------------- - -- Keys_Included_Except -- - -------------------------- - - function Keys_Included_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, New_Key) - and then Find (Right.Keys, K) = 0 - then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included_Except; - - function Keys_Included_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - is - begin - for J in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, J); - begin - if not Equivalent_Keys (K, X) - and then not Equivalent_Keys (K, Y) - and then Find (Right.Keys, K) = 0 - then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included_Except; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Big_Natural is - begin - return To_Big_Integer (Length (Container.Elements)); - end Length; - - ------------ - -- Remove -- - ------------ - - function Remove (Container : Map; Key : Key_Type) return Map is - J : constant Extended_Index := Find (Container.Keys, Key); - begin - return - (Keys => Remove (Container.Keys, J), - Elements => Remove (Container.Elements, J)); - end Remove; - - --------------- - -- Same_Keys -- - --------------- - - function Same_Keys (Left : Map; Right : Map) return Boolean is - (Keys_Included (Left, Right) - and Keys_Included (Left => Right, Right => Left)); - - --------- - -- Set -- - --------- - - function Set - (Container : Map; - Key : Key_Type; - New_Item : Element_Type) return Map - is - (Keys => Container.Keys, - Elements => - Set (Container.Elements, Find (Container.Keys, Key), New_Item)); - - ----------- - -- W_Get -- - ----------- - - function W_Get - (Container : Map; - Witness : Count_Type) return Element_Type - is - (Get (Container.Elements, Witness)); - - ------------- - -- Witness -- - ------------- - - function Witness (Container : Map; Key : Key_Type) return Count_Type is - (Find (Container.Keys, Key)); - -end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/libgnat/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads index f863cdc..9b4863a 100644 --- a/gcc/ada/libgnat/a-cofuma.ads +++ b/gcc/ada/libgnat/a-cofuma.ads @@ -29,368 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -pragma Ada_2012; -private with Ada.Containers.Functional_Base; - -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; - generic - type Key_Type (<>) is private; - type Element_Type (<>) is private; - - with function Equivalent_Keys - (Left : Key_Type; - Right : Key_Type) return Boolean is "="; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - - Enable_Handling_Of_Equivalence : Boolean := True; - -- This constant should only be set to False when no particular handling - -- of equivalence over keys is needed, that is, Equivalent_Keys defines a - -- key uniquely. - -package Ada.Containers.Functional_Maps with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - type Map is private with - Default_Initial_Condition => Is_Empty (Map) and Length (Map) = 0, - Iterable => (First => Iter_First, - Next => Iter_Next, - Has_Element => Iter_Has_Element, - Element => Iter_Element); - -- Maps are empty when default initialized. - -- "For in" quantification over maps should not be used. - -- "For of" quantification over maps iterates over keys. - -- Note that, for proof, "for of" quantification is understood modulo - -- equivalence (the range of quantification comprises all the keys that are - -- equivalent to any key of the map). - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Maps are axiomatized using Has_Key and Get, encoding respectively the - -- presence of a key in a map and an accessor to elements associated with - -- its keys. The length of a map is also added to protect Add against - -- overflows but it is not actually modeled. - - function Has_Key (Container : Map; Key : Key_Type) return Boolean with - -- Return True if Key is present in Container - - Global => null, - Post => - (if Enable_Handling_Of_Equivalence then - - -- Has_Key returns the same result on all equivalent keys - - (if (for some K of Container => Equivalent_Keys (K, Key)) then - Has_Key'Result)); - - function Get (Container : Map; Key : Key_Type) return Element_Type with - -- Return the element associated with Key in Container - - Global => null, - Pre => Has_Key (Container, Key), - Post => - (if Enable_Handling_Of_Equivalence then - - -- Get returns the same result on all equivalent keys - - Get'Result = W_Get (Container, Witness (Container, Key)) - and (for all K of Container => - (Equivalent_Keys (K, Key) = - (Witness (Container, Key) = Witness (Container, K))))); - - function Length (Container : Map) return Big_Natural with - Global => null; - -- Return the number of mappings in Container - - ------------------------ - -- Property Functions -- - ------------------------ - - function "<=" (Left : Map; Right : Map) return Boolean with - -- Map inclusion - - Global => null, - Post => - "<="'Result = - (for all Key of Left => - Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key)); - - function "=" (Left : Map; Right : Map) return Boolean with - -- Extensional equality over maps - - Global => null, - Post => - "="'Result = - ((for all Key of Left => - Has_Key (Right, Key) - and then Get (Right, Key) = Get (Left, Key)) - and (for all Key of Right => Has_Key (Left, Key))); - - pragma Warnings (Off, "unused variable ""Key"""); - function Is_Empty (Container : Map) return Boolean with - -- A map is empty if it contains no key - - Global => null, - Post => Is_Empty'Result = (for all Key of Container => False); - pragma Warnings (On, "unused variable ""Key"""); - - function Keys_Included (Left : Map; Right : Map) return Boolean - -- Returns True if every Key of Left is in Right - - with - Global => null, - Post => - Keys_Included'Result = (for all Key of Left => Has_Key (Right, Key)); - - function Same_Keys (Left : Map; Right : Map) return Boolean - -- Returns True if Left and Right have the same keys - - with - Global => null, - Post => - Same_Keys'Result = - (Keys_Included (Left, Right) - and Keys_Included (Left => Right, Right => Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Same_Keys); - - function Keys_Included_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - -- Returns True if Left contains only keys of Right and possibly New_Key - - with - Global => null, - Post => - Keys_Included_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, New_Key) then - Has_Key (Right, Key))); - - function Keys_Included_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - -- Returns True if Left contains only keys of Right and possibly X and Y - - with - Global => null, - Post => - Keys_Included_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, X) - and not Equivalent_Keys (Key, Y) - then - Has_Key (Right, Key))); - - function Elements_Equal_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - -- Returns True if all the keys of Left are mapped to the same elements in - -- Left and Right except New_Key. - - with - Global => null, - Post => - Elements_Equal_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, New_Key) then - Has_Key (Right, Key) - and then Get (Left, Key) = Get (Right, Key))); - - function Elements_Equal_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - -- Returns True if all the keys of Left are mapped to the same elements in - -- Left and Right except X and Y. - - with - Global => null, - Post => - Elements_Equal_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, X) - and not Equivalent_Keys (Key, Y) - then - Has_Key (Right, Key) - and then Get (Left, Key) = Get (Right, Key))); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Add - (Container : Map; - New_Key : Key_Type; - New_Item : Element_Type) return Map - -- Returns Container augmented with the mapping Key -> New_Item - - with - Global => null, - Pre => not Has_Key (Container, New_Key), - Post => - Length (Container) + 1 = Length (Add'Result) - and Has_Key (Add'Result, New_Key) - and Get (Add'Result, New_Key) = New_Item - and Container <= Add'Result - and Keys_Included_Except (Add'Result, Container, New_Key); - - function Empty_Map return Map with - -- Return an empty Map - - Global => null, - Post => - Length (Empty_Map'Result) = 0 - and Is_Empty (Empty_Map'Result); - - function Remove - (Container : Map; - Key : Key_Type) return Map - -- Returns Container without any mapping for Key - - with - Global => null, - Pre => Has_Key (Container, Key), - Post => - Length (Container) = Length (Remove'Result) + 1 - and not Has_Key (Remove'Result, Key) - and Remove'Result <= Container - and Keys_Included_Except (Container, Remove'Result, Key); - - function Set - (Container : Map; - Key : Key_Type; - New_Item : Element_Type) return Map - -- Returns Container, where the element associated with Key has been - -- replaced by New_Item. - - with - Global => null, - Pre => Has_Key (Container, Key), - Post => - Length (Container) = Length (Set'Result) - and Get (Set'Result, Key) = New_Item - and Same_Keys (Container, Set'Result) - and Elements_Equal_Except (Container, Set'Result, Key); - - ------------------------------ - -- Handling of Equivalence -- - ------------------------------ - - -- These functions are used to specify that Get returns the same value on - -- equivalent keys. They should not be used directly in user code. - - function Has_Witness (Container : Map; Witness : Count_Type) return Boolean - with - Ghost, - Global => null; - -- Returns True if there is a key with witness Witness in Container - - function Witness (Container : Map; Key : Key_Type) return Count_Type with - -- Returns the witness of Key in Container - - Ghost, - Global => null, - Pre => Has_Key (Container, Key), - Post => Has_Witness (Container, Witness'Result); - - function W_Get (Container : Map; Witness : Count_Type) return Element_Type - with - -- Returns the element associated with a witness in Container - - Ghost, - Global => null, - Pre => Has_Witness (Container, Witness); - - function Copy_Key (Key : Key_Type) return Key_Type is (Key); - function Copy_Element (Item : Element_Type) return Element_Type is (Item); - -- Elements and Keys of maps are copied by numerous primitives in this - -- package. This function causes GNATprove to verify that such a copy is - -- valid (in particular, it does not break the ownership policy of SPARK, - -- i.e. it does not contain pointers that could be used to alias mutable - -- data). - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - type Private_Key is private; - - function Iter_First (Container : Map) return Private_Key with - Global => null; - - function Iter_Has_Element - (Container : Map; - Key : Private_Key) return Boolean - with - Global => null; - - function Iter_Next (Container : Map; Key : Private_Key) return Private_Key - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - - function Iter_Element (Container : Map; Key : Private_Key) return Key_Type - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Has_Key); - -private - - pragma SPARK_Mode (Off); - - function "=" - (Left : Key_Type; - Right : Key_Type) return Boolean renames Equivalent_Keys; - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package Element_Containers is new Ada.Containers.Functional_Base - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - package Key_Containers is new Ada.Containers.Functional_Base - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - type Map is record - Keys : Key_Containers.Container; - Elements : Element_Containers.Container; - end record; - - type Private_Key is new Count_Type; - - function Iter_First (Container : Map) return Private_Key is (1); - - function Iter_Has_Element - (Container : Map; - Key : Private_Key) return Boolean - is - (Count_Type (Key) in 1 .. Key_Containers.Length (Container.Keys)); - - function Iter_Next - (Container : Map; - Key : Private_Key) return Private_Key - is - (if Key = Private_Key'Last then 0 else Key + 1); +package Ada.Containers.Functional_Maps with SPARK_Mode is - function Iter_Element - (Container : Map; - Key : Private_Key) return Key_Type - is - (Key_Containers.Get (Container.Keys, Count_Type (Key))); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/libgnat/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb deleted file mode 100644 index bbb3f7e..0000000 --- a/gcc/ada/libgnat/a-cofuse.adb +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_SETS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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/>. -- ------------------------------------------------------------------------------- - -pragma Ada_2012; - -package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is - use Containers; - - package Conversions is new Signed_Conversions (Int => Count_Type); - use Conversions; - - --------- - -- "=" -- - --------- - - function "=" (Left : Set; Right : Set) return Boolean is - (Left.Content <= Right.Content and Right.Content <= Left.Content); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Set; Right : Set) return Boolean is - (Left.Content <= Right.Content); - - --------- - -- Add -- - --------- - - function Add (Container : Set; Item : Element_Type) return Set is - (Content => - Add (Container.Content, Length (Container.Content) + 1, Item)); - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - (Find (Container.Content, Item) > 0); - - --------------- - -- Empty_Set -- - --------------- - - function Empty_Set return Set is - ((others => <>)); - - --------------------- - -- Included_Except -- - --------------------- - - function Included_Except - (Left : Set; - Right : Set; - Item : Element_Type) return Boolean - is - (for all E of Left => - Equivalent_Elements (E, Item) or Contains (Right, E)); - - ----------------------- - -- Included_In_Union -- - ----------------------- - - function Included_In_Union - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Container => - Contains (Left, Item) or Contains (Right, Item)); - - --------------------------- - -- Includes_Intersection -- - --------------------------- - - function Includes_Intersection - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Left => - (if Contains (Right, Item) then Contains (Container, Item))); - - ------------------ - -- Intersection -- - ------------------ - - function Intersection (Left : Set; Right : Set) return Set is - (Content => Intersection (Left.Content, Right.Content)); - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - (Length (Container.Content) = 0); - - ------------------ - -- Is_Singleton -- - ------------------ - - function Is_Singleton - (Container : Set; - New_Item : Element_Type) return Boolean - is - (Length (Container.Content) = 1 - and New_Item = Get (Container.Content, 1)); - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Big_Natural is - (To_Big_Integer (Length (Container.Content))); - - ----------------- - -- Not_In_Both -- - ----------------- - - function Not_In_Both - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Container => - not Contains (Right, Item) or not Contains (Left, Item)); - - ---------------- - -- No_Overlap -- - ---------------- - - function No_Overlap (Left : Set; Right : Set) return Boolean is - (Num_Overlaps (Left.Content, Right.Content) = 0); - - ------------------ - -- Num_Overlaps -- - ------------------ - - function Num_Overlaps (Left : Set; Right : Set) return Big_Natural is - (To_Big_Integer (Num_Overlaps (Left.Content, Right.Content))); - - ------------ - -- Remove -- - ------------ - - function Remove (Container : Set; Item : Element_Type) return Set is - (Content => Remove (Container.Content, Find (Container.Content, Item))); - - ----------- - -- Union -- - ----------- - - function Union (Left : Set; Right : Set) return Set is - (Content => Union (Left.Content, Right.Content)); - -end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/libgnat/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads index ce52f61..9c57ba1 100644 --- a/gcc/ada/libgnat/a-cofuse.ads +++ b/gcc/ada/libgnat/a-cofuse.ads @@ -29,308 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -pragma Ada_2012; -private with Ada.Containers.Functional_Base; - -with Ada.Numerics.Big_Numbers.Big_Integers; -use Ada.Numerics.Big_Numbers.Big_Integers; - generic - type Element_Type (<>) is private; - - with function Equivalent_Elements - (Left : Element_Type; - Right : Element_Type) return Boolean is "="; - - Enable_Handling_Of_Equivalence : Boolean := True; - -- This constant should only be set to False when no particular handling - -- of equivalence over elements is needed, that is, Equivalent_Elements - -- defines an element uniquely. - -package Ada.Containers.Functional_Sets with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - type Set is private with - Default_Initial_Condition => Is_Empty (Set), - Iterable => (First => Iter_First, - Next => Iter_Next, - Has_Element => Iter_Has_Element, - Element => Iter_Element); - -- Sets are empty when default initialized. - -- "For in" quantification over sets should not be used. - -- "For of" quantification over sets iterates over elements. - -- Note that, for proof, "for of" quantification is understood modulo - -- equivalence (the range of quantification comprises all the elements that - -- are equivalent to any element of the set). - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Sets are axiomatized using Contains, which encodes whether an element is - -- contained in a set. The length of a set is also added to protect Add - -- against overflows but it is not actually modeled. - - function Contains (Container : Set; Item : Element_Type) return Boolean with - -- Return True if Item is contained in Container - - Global => null, - Post => - (if Enable_Handling_Of_Equivalence then - - -- Contains returns the same result on all equivalent elements - - (if (for some E of Container => Equivalent_Elements (E, Item)) then - Contains'Result)); - - function Length (Container : Set) return Big_Natural with - Global => null; - -- Return the number of elements in Container - - ------------------------ - -- Property Functions -- - ------------------------ - - function "<=" (Left : Set; Right : Set) return Boolean with - -- Set inclusion - - Global => null, - Post => "<="'Result = (for all Item of Left => Contains (Right, Item)); - - function "=" (Left : Set; Right : Set) return Boolean with - -- Extensional equality over sets - - Global => null, - Post => "="'Result = (Left <= Right and Right <= Left); - - pragma Warnings (Off, "unused variable ""Item"""); - function Is_Empty (Container : Set) return Boolean with - -- A set is empty if it contains no element - - Global => null, - Post => - Is_Empty'Result = (for all Item of Container => False) - and Is_Empty'Result = (Length (Container) = 0); - pragma Warnings (On, "unused variable ""Item"""); - - function Included_Except - (Left : Set; - Right : Set; - Item : Element_Type) return Boolean - -- Return True if Left contains only elements of Right except possibly - -- Item. - - with - Global => null, - Post => - Included_Except'Result = - (for all E of Left => - Contains (Right, E) or Equivalent_Elements (E, Item)); - - function Includes_Intersection - (Container : Set; - Left : Set; - Right : Set) return Boolean - with - -- Return True if every element of the intersection of Left and Right is - -- in Container. - - Global => null, - Post => - Includes_Intersection'Result = - (for all Item of Left => - (if Contains (Right, Item) then Contains (Container, Item))); - - function Included_In_Union - (Container : Set; - Left : Set; - Right : Set) return Boolean - with - -- Return True if every element of Container is the union of Left and Right - - Global => null, - Post => - Included_In_Union'Result = - (for all Item of Container => - Contains (Left, Item) or Contains (Right, Item)); - - function Is_Singleton - (Container : Set; - New_Item : Element_Type) return Boolean - with - -- Return True Container only contains New_Item - - Global => null, - Post => - Is_Singleton'Result = - (for all Item of Container => Equivalent_Elements (Item, New_Item)); - - function Not_In_Both - (Container : Set; - Left : Set; - Right : Set) return Boolean - -- Return True if there are no elements in Container that are in Left and - -- Right. - - with - Global => null, - Post => - Not_In_Both'Result = - (for all Item of Container => - not Contains (Left, Item) or not Contains (Right, Item)); - - function No_Overlap (Left : Set; Right : Set) return Boolean with - -- Return True if there are no equivalent elements in Left and Right - - Global => null, - Post => - No_Overlap'Result = - (for all Item of Left => not Contains (Right, Item)); - - function Num_Overlaps (Left : Set; Right : Set) return Big_Natural with - -- Number of elements that are both in Left and Right - - Global => null, - Post => - Num_Overlaps'Result = Length (Intersection (Left, Right)) - and (if Left <= Right then Num_Overlaps'Result = Length (Left) - else Num_Overlaps'Result < Length (Left)) - and (if Right <= Left then Num_Overlaps'Result = Length (Right) - else Num_Overlaps'Result < Length (Right)) - and (Num_Overlaps'Result = 0) = No_Overlap (Left, Right); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Add (Container : Set; Item : Element_Type) return Set with - -- Return a new set containing all the elements of Container plus E - - Global => null, - Pre => not Contains (Container, Item), - Post => - Length (Add'Result) = Length (Container) + 1 - and Contains (Add'Result, Item) - and Container <= Add'Result - and Included_Except (Add'Result, Container, Item); - - function Empty_Set return Set with - -- Return a new empty set - - Global => null, - Post => Is_Empty (Empty_Set'Result); - - function Remove (Container : Set; Item : Element_Type) return Set with - -- Return a new set containing all the elements of Container except E - - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Remove'Result) = Length (Container) - 1 - and not Contains (Remove'Result, Item) - and Remove'Result <= Container - and Included_Except (Container, Remove'Result, Item); - - function Intersection (Left : Set; Right : Set) return Set with - -- Returns the intersection of Left and Right - - Global => null, - Post => - Intersection'Result <= Left - and Intersection'Result <= Right - and Includes_Intersection (Intersection'Result, Left, Right); - - function Union (Left : Set; Right : Set) return Set with - -- Returns the union of Left and Right - - Global => null, - Post => - Length (Union'Result) = - Length (Left) - Num_Overlaps (Left, Right) + Length (Right) - and Left <= Union'Result - and Right <= Union'Result - and Included_In_Union (Union'Result, Left, Right); - - function Copy_Element (Item : Element_Type) return Element_Type is (Item); - -- Elements of containers are copied by numerous primitives in this - -- package. This function causes GNATprove to verify that such a copy is - -- valid (in particular, it does not break the ownership policy of SPARK, - -- i.e. it does not contain pointers that could be used to alias mutable - -- data). - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - type Private_Key is private; - - function Iter_First (Container : Set) return Private_Key with - Global => null; - - function Iter_Has_Element - (Container : Set; - Key : Private_Key) return Boolean - with - Global => null; - - function Iter_Next - (Container : Set; - Key : Private_Key) return Private_Key - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - - function Iter_Element - (Container : Set; - Key : Private_Key) return Element_Type - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Contains); - -private - - pragma SPARK_Mode (Off); - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - function "=" - (Left : Element_Type; - Right : Element_Type) return Boolean renames Equivalent_Elements; - - package Containers is new Ada.Containers.Functional_Base - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - type Set is record - Content : Containers.Container; - end record; - - type Private_Key is new Count_Type; - - function Iter_First (Container : Set) return Private_Key is (1); - - function Iter_Has_Element - (Container : Set; - Key : Private_Key) return Boolean - is - (Count_Type (Key) in 1 .. Containers.Length (Container.Content)); - - function Iter_Next - (Container : Set; - Key : Private_Key) return Private_Key - is - (if Key = Private_Key'Last then 0 else Key + 1); +package Ada.Containers.Functional_Sets with SPARK_Mode is - function Iter_Element - (Container : Set; - Key : Private_Key) return Element_Type - is - (Containers.Get (Container.Content, Count_Type (Key))); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/libgnat/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb deleted file mode 100644 index 0d91da5..0000000 --- a/gcc/ada/libgnat/a-cofuve.adb +++ /dev/null @@ -1,262 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_VECTORS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2022, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- 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/>. -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is - use Containers; - - --------- - -- "<" -- - --------- - - function "<" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left.Content) < Length (Right.Content) - and then (for all I in Index_Type'First .. Last (Left) => - Get (Left.Content, I) = Get (Right.Content, I))); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left.Content) <= Length (Right.Content) - and then (for all I in Index_Type'First .. Last (Left) => - Get (Left.Content, I) = Get (Right.Content, I))); - - --------- - -- "=" -- - --------- - - function "=" (Left : Sequence; Right : Sequence) return Boolean is - (Left.Content = Right.Content); - - --------- - -- Add -- - --------- - - function Add - (Container : Sequence; - New_Item : Element_Type) return Sequence - is - (Content => - Add (Container.Content, - Index_Type'Val (Index_Type'Pos (Index_Type'First) + - Length (Container.Content)), - New_Item)); - - function Add - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - is - (Content => Add (Container.Content, Position, New_Item)); - - -------------------- - -- Constant_Range -- - -------------------- - - function Constant_Range - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean is - begin - for I in Fst .. Lst loop - if Get (Container.Content, I) /= Item then - return False; - end if; - end loop; - - return True; - end Constant_Range; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Container.Content, I) = Item then - return True; - end if; - end loop; - - return False; - end Contains; - - -------------------- - -- Empty_Sequence -- - -------------------- - - function Empty_Sequence return Sequence is - ((others => <>)); - - ------------------ - -- Equal_Except -- - ------------------ - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Index_Type) return Boolean - is - begin - if Length (Left.Content) /= Length (Right.Content) then - return False; - end if; - - for I in Index_Type'First .. Last (Left) loop - if I /= Position - and then Get (Left.Content, I) /= Get (Right.Content, I) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - is - begin - if Length (Left.Content) /= Length (Right.Content) then - return False; - end if; - - for I in Index_Type'First .. Last (Left) loop - if I /= X and then I /= Y - and then Get (Left.Content, I) /= Get (Right.Content, I) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - --------- - -- Get -- - --------- - - function Get (Container : Sequence; - Position : Extended_Index) return Element_Type - is - (Get (Container.Content, Position)); - - ---------- - -- Last -- - ---------- - - function Last (Container : Sequence) return Extended_Index is - (Index_Type'Val - ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container))); - - ------------ - -- Length -- - ------------ - - function Length (Container : Sequence) return Count_Type is - (Length (Container.Content)); - - ----------------- - -- Range_Equal -- - ----------------- - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Left, I) /= Get (Right, I) then - return False; - end if; - end loop; - - return True; - end Range_Equal; - - ------------------- - -- Range_Shifted -- - ------------------- - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Offset : Count_Type'Base) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Left, I) /= - Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset)) - then - return False; - end if; - end loop; - return True; - end Range_Shifted; - - ------------ - -- Remove -- - ------------ - - function Remove - (Container : Sequence; - Position : Index_Type) return Sequence - is - (Content => Remove (Container.Content, Position)); - - --------- - -- Set -- - --------- - - function Set - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - is - (Content => Set (Container.Content, Position, New_Item)); - -end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/libgnat/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads index 8622221..da0611e 100644 --- a/gcc/ada/libgnat/a-cofuve.ads +++ b/gcc/ada/libgnat/a-cofuve.ads @@ -29,383 +29,12 @@ -- <http://www.gnu.org/licenses/>. -- ------------------------------------------------------------------------------ -pragma Ada_2012; -private with Ada.Containers.Functional_Base; - generic - type Index_Type is (<>); - -- To avoid Constraint_Error being raised at run time, Index_Type'Base - -- should have at least one more element at the low end than Index_Type. - - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Functional_Vectors with - SPARK_Mode, - Annotate => (GNATprove, Always_Return) -is - - subtype Extended_Index is Index_Type'Base range - Index_Type'Pred (Index_Type'First) .. Index_Type'Last; - -- Index_Type with one more element at the low end of the range. - -- This type is never used but it forces GNATprove to check that there is - -- room for one more element at the low end of Index_Type. - - type Sequence is private - with Default_Initial_Condition => Length (Sequence) = 0, - Iterable => (First => Iter_First, - Has_Element => Iter_Has_Element, - Next => Iter_Next, - Element => Get); - -- Sequences are empty when default initialized. - -- Quantification over sequences can be done using the regular - -- quantification over its range or directly on its elements with "for of". - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Sequences are axiomatized using Length and Get, providing respectively - -- the length of a sequence and an accessor to its Nth element: - - function Length (Container : Sequence) return Count_Type with - -- Length of a sequence - - Global => null, - Post => - (Index_Type'Pos (Index_Type'First) - 1) + Length'Result <= - Index_Type'Pos (Index_Type'Last); - - function Get - (Container : Sequence; - Position : Extended_Index) return Element_Type - -- Access the Element at position Position in Container - - with - Global => null, - Pre => Position in Index_Type'First .. Last (Container); - - function Last (Container : Sequence) return Extended_Index with - -- Last index of a sequence - - Global => null, - Post => - Last'Result = - Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) + - Length (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last); - - function First return Extended_Index is (Index_Type'First) with - Global => null; - -- First index of a sequence - - ------------------------ - -- Property Functions -- - ------------------------ - - function "=" (Left : Sequence; Right : Sequence) return Boolean with - -- Extensional equality over sequences - - Global => null, - Post => - "="'Result = - (Length (Left) = Length (Right) - and then (for all N in Index_Type'First .. Last (Left) => - Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "="); - - function "<" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a strict subsequence of Right - - Global => null, - Post => - "<"'Result = - (Length (Left) < Length (Right) - and then (for all N in Index_Type'First .. Last (Left) => - Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<"); - - function "<=" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a subsequence of Right - - Global => null, - Post => - "<="'Result = - (Length (Left) <= Length (Right) - and then (for all N in Index_Type'First .. Last (Left) => - Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<="); - - function Contains - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean - -- Returns True if Item occurs in the range from Fst to Lst of Container - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Contains'Result = - (for some I in Fst .. Lst => Get (Container, I) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Constant_Range - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean - -- Returns True if every element of the range from Fst to Lst of Container - -- is equal to Item. - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Constant_Range'Result = - (for all I in Fst .. Lst => Get (Container, I) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Index_Type) return Boolean - -- Returns True is Left and Right are the same except at position Position - - with - Global => null, - Pre => Position <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all I in Index_Type'First .. Last (Left) => - (if I /= Position then Get (Left, I) = Get (Right, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Returns True is Left and Right are the same except at positions X and Y - - with - Global => null, - Pre => X <= Last (Left) and Y <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all I in Index_Type'First .. Last (Left) => - (if I /= X and I /= Y then - Get (Left, I) = Get (Right, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index) return Boolean - -- Returns True if the ranges from Fst to Lst contain the same elements in - -- Left and Right. - - with - Global => null, - Pre => Lst <= Last (Left) and Lst <= Last (Right), - Post => - Range_Equal'Result = - (for all I in Fst .. Lst => Get (Left, I) = Get (Right, I)); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal); - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Offset : Count_Type'Base) return Boolean - -- Returns True if the range from Fst to Lst in Left contains the same - -- elements as the range from Fst + Offset to Lst + Offset in Right. - - with - Global => null, - Pre => - Lst <= Last (Left) - and then - (if Offset < 0 then - Index_Type'Pos (Index_Type'Base'First) - Offset <= - Index_Type'Pos (Index_Type'First)) - and then - (if Fst <= Lst then - Offset in - Index_Type'Pos (Index_Type'First) - Index_Type'Pos (Fst) .. - (Index_Type'Pos (Index_Type'First) - 1) + Length (Right) - - Index_Type'Pos (Lst)), - Post => - Range_Shifted'Result = - ((for all I in Fst .. Lst => - Get (Left, I) = - Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset))) - and - (for all I in Index_Type'Val (Index_Type'Pos (Fst) + Offset) .. - Index_Type'Val (Index_Type'Pos (Lst) + Offset) - => - Get (Left, Index_Type'Val (Index_Type'Pos (I) - Offset)) = - Get (Right, I))); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Set - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except for the one at position Position which is replaced by New_Item. - - with - Global => null, - Pre => Position in Index_Type'First .. Last (Container), - Post => - Get (Set'Result, Position) = New_Item - and then Equal_Except (Container, Set'Result, Position); - - function Add (Container : Sequence; New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- plus New_Item at the end. - - with - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then Last (Container) < Index_Type'Last, - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Last (Add'Result)) = New_Item - and then Container <= Add'Result; - - function Add - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - with - -- Returns a new sequence which contains the same elements as Container - -- except that New_Item has been inserted at position Position. - - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then Last (Container) < Index_Type'Last - and then Position <= Extended_Index'Succ (Last (Container)), - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Position) = New_Item - and then Range_Equal - (Left => Container, - Right => Add'Result, - Fst => Index_Type'First, - Lst => Index_Type'Pred (Position)) - and then Range_Shifted - (Left => Container, - Right => Add'Result, - Fst => Position, - Lst => Last (Container), - Offset => 1); - - function Remove - (Container : Sequence; - Position : Index_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except that the element at position Position has been removed. - - with - Global => null, - Pre => Position in Index_Type'First .. Last (Container), - Post => - Length (Remove'Result) = Length (Container) - 1 - and then Range_Equal - (Left => Container, - Right => Remove'Result, - Fst => Index_Type'First, - Lst => Index_Type'Pred (Position)) - and then Range_Shifted - (Left => Remove'Result, - Right => Container, - Fst => Position, - Lst => Last (Remove'Result), - Offset => 1); - - function Copy_Element (Item : Element_Type) return Element_Type is (Item); - -- Elements of containers are copied by numerous primitives in this - -- package. This function causes GNATprove to verify that such a copy is - -- valid (in particular, it does not break the ownership policy of SPARK, - -- i.e. it does not contain pointers that could be used to alias mutable - -- data). - - function Empty_Sequence return Sequence with - -- Return an empty Sequence - - Global => null, - Post => Length (Empty_Sequence'Result) = 0; - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - function Iter_First (Container : Sequence) return Extended_Index with - Global => null; - - function Iter_Has_Element - (Container : Sequence; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Iter_Has_Element'Result = - (Position in Index_Type'First .. Last (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); - - function Iter_Next - (Container : Sequence; - Position : Extended_Index) return Extended_Index - with - Global => null, - Pre => Iter_Has_Element (Container, Position); - -private - - pragma SPARK_Mode (Off); - - package Containers is new Ada.Containers.Functional_Base - (Index_Type => Index_Type, - Element_Type => Element_Type); - - type Sequence is record - Content : Containers.Container; - end record; - - function Iter_First (Container : Sequence) return Extended_Index is - (Index_Type'First); - - function Iter_Next - (Container : Sequence; - Position : Extended_Index) return Extended_Index - is - (if Position = Extended_Index'Last then - Extended_Index'First - else - Extended_Index'Succ (Position)); +package Ada.Containers.Functional_Vectors with SPARK_Mode is - function Iter_Has_Element - (Container : Sequence; - Position : Extended_Index) return Boolean - is - (Position in Index_Type'First .. - (Index_Type'Val - ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container)))); + pragma Compile_Time_Error + (True, + "This package has been moved to the SPARK library shipped with any" + & " SPARK release starting with version 23."); end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads index 8888a8c..fed41ec 100644 --- a/gcc/ada/libgnat/a-coorse.ads +++ b/gcc/ada/libgnat/a-coorse.ads @@ -57,9 +57,9 @@ is type Set is tagged private with Constant_Indexing => Constant_Reference, Default_Iterator => Iterate, - Iterator_Element => Element_Type; - -- Aggregate => (Empty => Empty, - -- Add_Unnamed => Include); + Iterator_Element => Element_Type, + Aggregate => (Empty => Empty, + Add_Unnamed => Include); pragma Preelaborable_Initialization (Set); diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb index e301564..831a18e 100644 --- a/gcc/ada/libgnat/a-strsup.adb +++ b/gcc/ada/libgnat/a-strsup.adb @@ -1651,10 +1651,9 @@ package body Ada.Strings.Superbounded with SPARK_Mode is raise Index_Error; end if; - if High >= Low then - Result.Data (1 .. High - Low + 1) := Source.Data (Low .. High); - Result.Current_Length := High - Low + 1; - end if; + Result.Current_Length := (if Low > High then 0 else High - Low + 1); + Result.Data (1 .. Result.Current_Length) := + Source.Data (Low .. High); end return; end Super_Slice; @@ -1671,12 +1670,8 @@ package body Ada.Strings.Superbounded with SPARK_Mode is raise Index_Error; end if; - if High >= Low then - Target.Data (1 .. High - Low + 1) := Source.Data (Low .. High); - Target.Current_Length := High - Low + 1; - else - Target.Current_Length := 0; - end if; + Target.Current_Length := (if Low > High then 0 else High - Low + 1); + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end Super_Slice; ---------------- diff --git a/gcc/ada/libgnat/a-stwisu.adb b/gcc/ada/libgnat/a-stwisu.adb index a615ff3..d325676 100644 --- a/gcc/ada/libgnat/a-stwisu.adb +++ b/gcc/ada/libgnat/a-stwisu.adb @@ -1497,7 +1497,7 @@ package body Ada.Strings.Wide_Superbounded is raise Index_Error; end if; - Result.Current_Length := High - Low + 1; + Result.Current_Length := (if Low > High then 0 else High - Low + 1); Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); end return; end Super_Slice; @@ -1513,10 +1513,10 @@ package body Ada.Strings.Wide_Superbounded is or else High > Source.Current_Length then raise Index_Error; - else - Target.Current_Length := High - Low + 1; - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end if; + + Target.Current_Length := (if Low > High then 0 else High - Low + 1); + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end Super_Slice; ---------------- diff --git a/gcc/ada/libgnat/a-stzsup.adb b/gcc/ada/libgnat/a-stzsup.adb index d973993..6153bbe 100644 --- a/gcc/ada/libgnat/a-stzsup.adb +++ b/gcc/ada/libgnat/a-stzsup.adb @@ -1498,11 +1498,11 @@ package body Ada.Strings.Wide_Wide_Superbounded is or else High > Source.Current_Length then raise Index_Error; - else - Result.Current_Length := High - Low + 1; - Result.Data (1 .. Result.Current_Length) := - Source.Data (Low .. High); end if; + + Result.Current_Length := (if Low > High then 0 else High - Low + 1); + Result.Data (1 .. Result.Current_Length) := + Source.Data (Low .. High); end return; end Super_Slice; @@ -1517,10 +1517,10 @@ package body Ada.Strings.Wide_Wide_Superbounded is or else High > Source.Current_Length then raise Index_Error; - else - Target.Current_Length := High - Low + 1; - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end if; + + Target.Current_Length := (if Low > High then 0 else High - Low + 1); + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); end Super_Slice; ---------------- diff --git a/gcc/ada/libgnat/s-imagei.adb b/gcc/ada/libgnat/s-imagei.adb index 8997e3c..c467777 100644 --- a/gcc/ada/libgnat/s-imagei.adb +++ b/gcc/ada/libgnat/s-imagei.adb @@ -177,6 +177,8 @@ package body System.Image_I is begin if V >= 0 then + pragma Annotate (CodePeer, False_Positive, "test always false", + "V can be positive"); S (1) := ' '; P := 1; pragma Assert (P < S'Last); diff --git a/gcc/ada/libgnat/s-maccod.ads b/gcc/ada/libgnat/s-maccod.ads index c3abf07..df7c7df 100644 --- a/gcc/ada/libgnat/s-maccod.ads +++ b/gcc/ada/libgnat/s-maccod.ads @@ -33,7 +33,9 @@ -- operations, and also for machine code statements. See GNAT documentation -- for full details. -package System.Machine_Code is +package System.Machine_Code + with SPARK_Mode => Off +is pragma No_Elaboration_Code_All; pragma Pure; diff --git a/gcc/ada/libgnat/s-powflt.ads b/gcc/ada/libgnat/s-powflt.ads index bf5d66f..24e22c9 100644 --- a/gcc/ada/libgnat/s-powflt.ads +++ b/gcc/ada/libgnat/s-powflt.ads @@ -29,17 +29,41 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a powers of ten table used for real conversions +-- This package provides tables of powers used for real conversions package System.Powten_Flt is pragma Pure; Maxpow_Exact : constant := 10; - -- Largest power of ten exactly representable with Float. It is equal to + -- Largest power of five exactly representable with Float. It is equal to -- floor (M * log 2 / log 5), when M is the size of the mantissa (24). + -- It also works for any number of the form 5*(2**N) and in particular 10. Maxpow : constant := Maxpow_Exact * 2; - -- Largest power of ten exactly representable with a double Float + -- Largest power of five exactly representable with double Float + + Powfive : constant array (0 .. Maxpow, 1 .. 2) of Float := + [00 => [5.0**00, 0.0], + 01 => [5.0**01, 0.0], + 02 => [5.0**02, 0.0], + 03 => [5.0**03, 0.0], + 04 => [5.0**04, 0.0], + 05 => [5.0**05, 0.0], + 06 => [5.0**06, 0.0], + 07 => [5.0**07, 0.0], + 08 => [5.0**08, 0.0], + 09 => [5.0**09, 0.0], + 10 => [5.0**10, 0.0], + 11 => [5.0**11, 5.0**11 - Float'Machine (5.0**11)], + 12 => [5.0**12, 5.0**12 - Float'Machine (5.0**12)], + 13 => [5.0**13, 5.0**13 - Float'Machine (5.0**13)], + 14 => [5.0**14, 5.0**14 - Float'Machine (5.0**14)], + 15 => [5.0**15, 5.0**15 - Float'Machine (5.0**15)], + 16 => [5.0**16, 5.0**16 - Float'Machine (5.0**16)], + 17 => [5.0**17, 5.0**17 - Float'Machine (5.0**17)], + 18 => [5.0**18, 5.0**18 - Float'Machine (5.0**18)], + 19 => [5.0**19, 5.0**19 - Float'Machine (5.0**19)], + 20 => [5.0**20, 5.0**20 - Float'Machine (5.0**20)]]; Powten : constant array (0 .. Maxpow, 1 .. 2) of Float := [00 => [1.0E+00, 0.0], diff --git a/gcc/ada/libgnat/s-powlfl.ads b/gcc/ada/libgnat/s-powlfl.ads index a8612db..a627c0c 100644 --- a/gcc/ada/libgnat/s-powlfl.ads +++ b/gcc/ada/libgnat/s-powlfl.ads @@ -29,17 +29,74 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a powers of ten table used for real conversions +-- This package provides tables of powers used for real conversions package System.Powten_LFlt is pragma Pure; Maxpow_Exact : constant := 22; - -- Largest power of ten exactly representable with Long_Float. It is equal + -- Largest power of five exactly representable with Long_Float. It is equal -- to floor (M * log 2 / log 5), when M is the size of the mantissa (53). + -- It also works for any number of the form 5*(2**N) and in particular 10. Maxpow : constant := Maxpow_Exact * 2; - -- Largest power of ten exactly representable with a double Long_Float + -- Largest power of five exactly representable with double Long_Float + + Powfive : constant array (0 .. Maxpow, 1 .. 2) of Long_Float := + [00 => [5.0**00, 0.0], + 01 => [5.0**01, 0.0], + 02 => [5.0**02, 0.0], + 03 => [5.0**03, 0.0], + 04 => [5.0**04, 0.0], + 05 => [5.0**05, 0.0], + 06 => [5.0**06, 0.0], + 07 => [5.0**07, 0.0], + 08 => [5.0**08, 0.0], + 09 => [5.0**09, 0.0], + 10 => [5.0**10, 0.0], + 11 => [5.0**11, 0.0], + 12 => [5.0**12, 0.0], + 13 => [5.0**13, 0.0], + 14 => [5.0**14, 0.0], + 15 => [5.0**15, 0.0], + 16 => [5.0**16, 0.0], + 17 => [5.0**17, 0.0], + 18 => [5.0**18, 0.0], + 19 => [5.0**19, 0.0], + 20 => [5.0**20, 0.0], + 21 => [5.0**21, 0.0], + 22 => [5.0**22, 0.0], + 23 => [5.0**23, 5.0**23 - Long_Float'Machine (5.0**23)], + 24 => [5.0**24, 5.0**24 - Long_Float'Machine (5.0**24)], + 25 => [5.0**25, 5.0**25 - Long_Float'Machine (5.0**25)], + 26 => [5.0**26, 5.0**26 - Long_Float'Machine (5.0**26)], + 27 => [5.0**27, 5.0**27 - Long_Float'Machine (5.0**27)], + 28 => [5.0**28, 5.0**28 - Long_Float'Machine (5.0**28)], + 29 => [5.0**29, 5.0**29 - Long_Float'Machine (5.0**29)], + 30 => [5.0**30, 5.0**30 - Long_Float'Machine (5.0**30)], + 31 => [5.0**31, 5.0**31 - Long_Float'Machine (5.0**31)], + 32 => [5.0**32, 5.0**32 - Long_Float'Machine (5.0**32)], + 33 => [5.0**33, 5.0**33 - Long_Float'Machine (5.0**33)], + 34 => [5.0**34, 5.0**34 - Long_Float'Machine (5.0**34)], + 35 => [5.0**35, 5.0**35 - Long_Float'Machine (5.0**35)], + 36 => [5.0**36, 5.0**36 - Long_Float'Machine (5.0**36)], + 37 => [5.0**37, 5.0**37 - Long_Float'Machine (5.0**37)], + 38 => [5.0**38, 5.0**38 - Long_Float'Machine (5.0**38)], + 39 => [5.0**39, 5.0**39 - Long_Float'Machine (5.0**39)], + 40 => [5.0**40, 5.0**40 - Long_Float'Machine (5.0**40)], + 41 => [5.0**41, 5.0**41 - Long_Float'Machine (5.0**41)], + 42 => [5.0**42, 5.0**42 - Long_Float'Machine (5.0**42)], + 43 => [5.0**43, 5.0**43 - Long_Float'Machine (5.0**43)], + 44 => [5.0**44, 5.0**44 - Long_Float'Machine (5.0**44)]]; + + Powfive_100 : constant array (1 .. 2) of Long_Float := + [5.0**100, 5.0**100 - Long_Float'Machine (5.0**100)]; + + Powfive_200 : constant array (1 .. 2) of Long_Float := + [5.0**200, 5.0**200 - Long_Float'Machine (5.0**200)]; + + Powfive_300 : constant array (1 .. 2) of Long_Float := + [5.0**300, 5.0**300 - Long_Float'Machine (5.0**300)]; Powten : constant array (0 .. Maxpow, 1 .. 2) of Long_Float := [00 => [1.0E+00, 0.0], diff --git a/gcc/ada/libgnat/s-powllf.ads b/gcc/ada/libgnat/s-powllf.ads index 0640ea4..4b5f1ae 100644 --- a/gcc/ada/libgnat/s-powllf.ads +++ b/gcc/ada/libgnat/s-powllf.ads @@ -29,19 +29,86 @@ -- -- ------------------------------------------------------------------------------ --- This package provides a powers of ten table used for real conversions +-- This package provides tables of powers used for real conversions package System.Powten_LLF is pragma Pure; Maxpow_Exact : constant := (if Long_Long_Float'Machine_Mantissa = 64 then 27 else 22); - -- Largest power of ten exactly representable with Long_Long_Float. It is + -- Largest power of five exactly representable with Long_Long_Float. It is -- equal to floor (M * log 2 / log 5), when M is the size of the mantissa -- assumed to be either 64 for IEEE Extended or 53 for IEEE Double. + -- It also works for any number of the form 5*(2**N) and in particular 10. Maxpow : constant := Maxpow_Exact * 2; - -- Largest power of ten exactly representable with a double Long_Long_Float + -- Largest power of five exactly representable with double Long_Long_Float + + Powfive : constant array (0 .. 54, 1 .. 2) of Long_Long_Float := + [00 => [5.0**00, 0.0], + 01 => [5.0**01, 0.0], + 02 => [5.0**02, 0.0], + 03 => [5.0**03, 0.0], + 04 => [5.0**04, 0.0], + 05 => [5.0**05, 0.0], + 06 => [5.0**06, 0.0], + 07 => [5.0**07, 0.0], + 08 => [5.0**08, 0.0], + 09 => [5.0**09, 0.0], + 10 => [5.0**10, 0.0], + 11 => [5.0**11, 0.0], + 12 => [5.0**12, 0.0], + 13 => [5.0**13, 0.0], + 14 => [5.0**14, 0.0], + 15 => [5.0**15, 0.0], + 16 => [5.0**16, 0.0], + 17 => [5.0**17, 0.0], + 18 => [5.0**18, 0.0], + 19 => [5.0**19, 0.0], + 20 => [5.0**20, 0.0], + 21 => [5.0**21, 0.0], + 22 => [5.0**22, 0.0], + 23 => [5.0**23, 5.0**23 - Long_Long_Float'Machine (5.0**23)], + 24 => [5.0**24, 5.0**24 - Long_Long_Float'Machine (5.0**24)], + 25 => [5.0**25, 5.0**25 - Long_Long_Float'Machine (5.0**25)], + 26 => [5.0**26, 5.0**26 - Long_Long_Float'Machine (5.0**26)], + 27 => [5.0**27, 5.0**27 - Long_Long_Float'Machine (5.0**27)], + 28 => [5.0**28, 5.0**28 - Long_Long_Float'Machine (5.0**28)], + 29 => [5.0**29, 5.0**29 - Long_Long_Float'Machine (5.0**29)], + 30 => [5.0**30, 5.0**30 - Long_Long_Float'Machine (5.0**30)], + 31 => [5.0**31, 5.0**31 - Long_Long_Float'Machine (5.0**31)], + 32 => [5.0**32, 5.0**32 - Long_Long_Float'Machine (5.0**32)], + 33 => [5.0**33, 5.0**33 - Long_Long_Float'Machine (5.0**33)], + 34 => [5.0**34, 5.0**34 - Long_Long_Float'Machine (5.0**34)], + 35 => [5.0**35, 5.0**35 - Long_Long_Float'Machine (5.0**35)], + 36 => [5.0**36, 5.0**36 - Long_Long_Float'Machine (5.0**36)], + 37 => [5.0**37, 5.0**37 - Long_Long_Float'Machine (5.0**37)], + 38 => [5.0**38, 5.0**38 - Long_Long_Float'Machine (5.0**38)], + 39 => [5.0**39, 5.0**39 - Long_Long_Float'Machine (5.0**39)], + 40 => [5.0**40, 5.0**40 - Long_Long_Float'Machine (5.0**40)], + 41 => [5.0**41, 5.0**41 - Long_Long_Float'Machine (5.0**41)], + 42 => [5.0**42, 5.0**42 - Long_Long_Float'Machine (5.0**42)], + 43 => [5.0**43, 5.0**43 - Long_Long_Float'Machine (5.0**43)], + 44 => [5.0**44, 5.0**44 - Long_Long_Float'Machine (5.0**44)], + 45 => [5.0**45, 5.0**45 - Long_Long_Float'Machine (5.0**45)], + 46 => [5.0**46, 5.0**46 - Long_Long_Float'Machine (5.0**46)], + 47 => [5.0**47, 5.0**47 - Long_Long_Float'Machine (5.0**47)], + 48 => [5.0**48, 5.0**48 - Long_Long_Float'Machine (5.0**48)], + 49 => [5.0**49, 5.0**49 - Long_Long_Float'Machine (5.0**49)], + 50 => [5.0**50, 5.0**50 - Long_Long_Float'Machine (5.0**50)], + 51 => [5.0**51, 5.0**51 - Long_Long_Float'Machine (5.0**51)], + 52 => [5.0**52, 5.0**52 - Long_Long_Float'Machine (5.0**52)], + 53 => [5.0**53, 5.0**53 - Long_Long_Float'Machine (5.0**53)], + 54 => [5.0**54, 5.0**54 - Long_Long_Float'Machine (5.0**54)]]; + + Powfive_100 : constant array (1 .. 2) of Long_Long_Float := + [5.0**100, 5.0**100 - Long_Long_Float'Machine (5.0**100)]; + + Powfive_200 : constant array (1 .. 2) of Long_Long_Float := + [5.0**200, 5.0**200 - Long_Long_Float'Machine (5.0**200)]; + + Powfive_300 : constant array (1 .. 2) of Long_Long_Float := + [5.0**300, 5.0**300 - Long_Long_Float'Machine (5.0**300)]; Powten : constant array (0 .. 54, 1 .. 2) of Long_Long_Float := [00 => [1.0E+00, 0.0], diff --git a/gcc/ada/libgnat/s-valflt.ads b/gcc/ada/libgnat/s-valflt.ads index 788dd8a..cc8f583 100644 --- a/gcc/ada/libgnat/s-valflt.ads +++ b/gcc/ada/libgnat/s-valflt.ads @@ -42,7 +42,10 @@ package System.Val_Flt is package Impl is new Val_Real (Float, System.Powten_Flt.Maxpow, - System.Powten_Flt.Powten'Address, + System.Powten_Flt.Powfive'Address, + System.Null_Address, + System.Null_Address, + System.Null_Address, Unsigned_Types.Unsigned); function Scan_Float diff --git a/gcc/ada/libgnat/s-vallfl.ads b/gcc/ada/libgnat/s-vallfl.ads index cd894cd..12be755 100644 --- a/gcc/ada/libgnat/s-vallfl.ads +++ b/gcc/ada/libgnat/s-vallfl.ads @@ -42,7 +42,10 @@ package System.Val_LFlt is package Impl is new Val_Real (Long_Float, System.Powten_LFlt.Maxpow, - System.Powten_LFlt.Powten'Address, + System.Powten_LFlt.Powfive'Address, + System.Powten_LFlt.Powfive_100'Address, + System.Powten_LFlt.Powfive_200'Address, + System.Powten_LFlt.Powfive_300'Address, Unsigned_Types.Long_Long_Unsigned); function Scan_Long_Float diff --git a/gcc/ada/libgnat/s-valllf.ads b/gcc/ada/libgnat/s-valllf.ads index 959a27d..80566c3 100644 --- a/gcc/ada/libgnat/s-valllf.ads +++ b/gcc/ada/libgnat/s-valllf.ads @@ -42,7 +42,10 @@ package System.Val_LLF is package Impl is new Val_Real (Long_Long_Float, System.Powten_LLF.Maxpow, - System.Powten_LLF.Powten'Address, + System.Powten_LLF.Powfive'Address, + System.Powten_LLF.Powfive_100'Address, + System.Powten_LLF.Powfive_200'Address, + System.Powten_LLF.Powfive_300'Address, System.Unsigned_Types.Long_Long_Unsigned); function Scan_Long_Long_Float diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index c9e5505..079c48b 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -43,18 +43,13 @@ package body System.Val_Real is pragma Assert (Num'Machine_Mantissa <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - Need_Extra : constant Boolean := Num'Machine_Mantissa > Uns'Size - 4; - -- If the mantissa of the floating-point type is almost as large as the - -- unsigned type, we do not have enough space for an extra digit in the - -- unsigned type so we handle the extra digit separately, at the cost of - -- a bit more work in Integer_to_Real. + Is_Large_Type : constant Boolean := Num'Machine_Mantissa >= 53; + -- True if the floating-point type is at least IEEE Double - Precision_Limit : constant Uns := - (if Need_Extra then 2**Num'Machine_Mantissa - 1 else 2**Uns'Size - 1); - -- If we handle the extra digit separately, we use the precision of the - -- floating-point type so that the conversion is exact. + Precision_Limit : constant Uns := 2**Num'Machine_Mantissa - 1; + -- See below for the rationale - package Impl is new Value_R (Uns, Precision_Limit, Round => Need_Extra); + package Impl is new Value_R (Uns, 2, Precision_Limit, Round => False); subtype Base_T is Unsigned range 2 .. 16; @@ -64,18 +59,21 @@ package body System.Val_Real is Maxexp32 : constant array (Base_T) of Positive := [2 => 127, 3 => 80, 4 => 63, 5 => 55, 6 => 49, - 7 => 45, 8 => 42, 9 => 40, 10 => 38, 11 => 37, + 7 => 45, 8 => 42, 9 => 40, 10 => 55, 11 => 37, 12 => 35, 13 => 34, 14 => 33, 15 => 32, 16 => 31]; + -- The actual value for 10 is 38 but we also use scaling for 10 Maxexp64 : constant array (Base_T) of Positive := [2 => 1023, 3 => 646, 4 => 511, 5 => 441, 6 => 396, - 7 => 364, 8 => 341, 9 => 323, 10 => 308, 11 => 296, + 7 => 364, 8 => 341, 9 => 323, 10 => 441, 11 => 296, 12 => 285, 13 => 276, 14 => 268, 15 => 262, 16 => 255]; + -- The actual value for 10 is 308 but we also use scaling for 10 Maxexp80 : constant array (Base_T) of Positive := [2 => 16383, 3 => 10337, 4 => 8191, 5 => 7056, 6 => 6338, - 7 => 5836, 8 => 5461, 9 => 5168, 10 => 4932, 11 => 4736, + 7 => 5836, 8 => 5461, 9 => 5168, 10 => 7056, 11 => 4736, 12 => 4570, 13 => 4427, 14 => 4303, 15 => 4193, 16 => 4095]; + -- The actual value for 10 is 4932 but we also use scaling for 10 package Double_Real is new System.Double_Real (Num); use type Double_Real.Double_T; @@ -83,17 +81,28 @@ package body System.Val_Real is subtype Double_T is Double_Real.Double_T; -- The double floating-point type + function Exact_Log2 (N : Unsigned) return Positive is + (case N is + when 2 => 1, + when 4 => 2, + when 8 => 3, + when 16 => 4, + when others => raise Program_Error); + -- Return the exponent of a power of 2 + function Integer_to_Real (Str : String; - Val : Uns; + Val : Impl.Value_Array; Base : Unsigned; - Scale : Integer; - Extra : Unsigned; + Scale : Impl.Scale_Array; Minus : Boolean) return Num; -- Convert the real value from integer to real representation - function Large_Powten (Exp : Natural) return Double_T; - -- Return 10.0**Exp as a double number, where Exp > Maxpow + function Large_Powfive (Exp : Natural) return Double_T; + -- Return 5.0**Exp as a double number, where Exp > Maxpow + + function Large_Powfive (Exp : Natural; S : out Natural) return Double_T; + -- Return Num'Scaling (5.0**Exp, -S) as a double number where Exp > Maxexp --------------------- -- Integer_to_Real -- @@ -101,10 +110,9 @@ package body System.Val_Real is function Integer_to_Real (Str : String; - Val : Uns; + Val : Impl.Value_Array; Base : Unsigned; - Scale : Integer; - Extra : Unsigned; + Scale : Impl.Scale_Array; Minus : Boolean) return Num is pragma Assert (Base in 2 .. 16); @@ -120,9 +128,9 @@ package body System.Val_Real is else raise Program_Error); -- Maximum exponent of the base that can fit in Num - R_Val : Num; D_Val : Double_T; - S : Integer := Scale; + R_Val : Num; + S : Integer; begin -- We call the floating-point processor reset routine so we can be sure @@ -134,82 +142,78 @@ package body System.Val_Real is System.Float_Control.Reset; end if; - -- Take into account the extra digit, i.e. do the two computations - - -- (1) R_Val := R_Val * Num (B) + Num (Extra) - -- (2) S := S - 1 + -- First convert the integer mantissa into a double real. The conversion + -- of each part is exact, given the precision limit we used above. Then, + -- if the contribution of the low part might be nonnull, scale the high + -- part appropriately and add the low part to the result. - -- In the first, the three operands are exact, so using an FMA would - -- be ideal, but we are most likely running on the x87 FPU, hence we - -- may not have one. That is why we turn the multiplication into an - -- iterated addition with exact error handling, so that we can do a - -- single rounding at the end. + if Val (2) = 0 then + D_Val := Double_Real.To_Double (Num (Val (1))); + S := Scale (1); - if Need_Extra and then Extra > 0 then + else declare - B : Unsigned := Base; - Acc : Num := 0.0; - Err : Num := 0.0; - Fac : Num := Num (Val); - DS : Double_T; + V1 : constant Num := Num (Val (1)); + V2 : constant Num := Num (Val (2)); + + DS : Positive; begin - loop - -- If B is odd, add one factor. Note that the accumulator is - -- never larger than the factor at this point (it is in fact - -- never larger than the factor minus the initial value). - - if B rem 2 /= 0 then - if Acc = 0.0 then - Acc := Fac; - else - DS := Double_Real.Quick_Two_Sum (Fac, Acc); - Acc := DS.Hi; - Err := Err + DS.Lo; - end if; - exit when B = 1; - end if; + DS := Scale (1) - Scale (2); - -- Now B is (morally) even, halve it and double the factor, - -- which is always an exact operation. + case Base is + -- If the base is a power of two, we use the efficient Scaling + -- attribute up to an amount worth a double mantissa. - B := B / 2; - Fac := Fac * 2.0; - end loop; + when 2 | 4 | 8 | 16 => + declare + L : constant Positive := Exact_Log2 (Base); - -- Add Extra to the error, which are both small integers + begin + if DS <= 2 * Num'Machine_Mantissa / L then + DS := DS * L; + D_Val := + Double_Real.Quick_Two_Sum (Num'Scaling (V1, DS), V2); + S := Scale (2); - D_Val := Double_Real.Quick_Two_Sum (Acc, Err + Num (Extra)); + else + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end if; + end; - S := S - 1; - end; + -- If the base is 10, we also scale up to an amount worth a + -- double mantissa. - -- Or else, if the Extra digit is zero, do the exact conversion + when 10 => + declare + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; - elsif Need_Extra then - D_Val := Double_Real.To_Double (Num (Val)); + begin + if DS <= Maxpow then + D_Val := Powfive (DS) * Num'Scaling (V1, DS) + V2; + S := Scale (2); - -- Otherwise, the value contains more bits than the mantissa so do the - -- conversion in two steps. + else + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end if; + end; - else - declare - Mask : constant Uns := 2**(Uns'Size - Num'Machine_Mantissa) - 1; - Hi : constant Uns := Val and not Mask; - Lo : constant Uns := Val and Mask; + -- Inaccurate implementation for other bases - begin - if Hi = 0 then - D_Val := Double_Real.To_Double (Num (Lo)); - else - D_Val := Double_Real.Quick_Two_Sum (Num (Hi), Num (Lo)); - end if; + when others => + D_Val := Double_Real.To_Double (V1); + S := Scale (1); + end case; end; end if; -- Compute the final value by applying the scaling, if any - if Val = 0 or else S = 0 then + if (Val (1) = 0 and then Val (2) = 0) or else S = 0 then R_Val := Double_Real.To_Single (D_Val); else @@ -218,67 +222,58 @@ package body System.Val_Real is -- attribute with an overflow check, if it is not 2, to catch -- ludicrous exponents that would result in an infinity or zero. - when 2 => - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 4 => - if Integer'First / 2 <= S and then S <= Integer'Last / 2 then - S := S * 2; - end if; - - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 8 => - if Integer'First / 3 <= S and then S <= Integer'Last / 3 then - S := S * 3; - end if; - - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); - - when 16 => - if Integer'First / 4 <= S and then S <= Integer'Last / 4 then - S := S * 4; - end if; + when 2 | 4 | 8 | 16 => + declare + L : constant Positive := Exact_Log2 (Base); - R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); + begin + if Integer'First / L <= S and then S <= Integer'Last / L then + S := S * L; + end if; - -- If the base is 10, use a double implementation for the sake - -- of accuracy, to be removed when exponentiation is improved. + R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); + end; - -- When the exponent is positive, we can do the computation - -- directly because, if the exponentiation overflows, then - -- the final value overflows as well. But when the exponent - -- is negative, we may need to do it in two steps to avoid - -- an artificial underflow. + -- If the base is 10, we use a double implementation for the sake + -- of accuracy combining powers of 5 and scaling attribute. Using + -- this combination is better than using powers of 10 only because + -- the Large_Powfive function may overflow only if the final value + -- will also either overflow or underflow, thus making it possible + -- to use a single division for the case of negative powers of 10. when 10 => declare - Powten : constant array (0 .. Maxpow) of Double_T; - pragma Import (Ada, Powten); - for Powten'Address use Powten_Address; + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; + + RS : Natural; begin if S > 0 then if S <= Maxpow then - D_Val := D_Val * Powten (S); + D_Val := D_Val * Powfive (S); else - D_Val := D_Val * Large_Powten (S); + D_Val := D_Val * Large_Powfive (S); end if; else - if S < -Maxexp then - D_Val := D_Val / Large_Powten (Maxexp); - S := S + Maxexp; - end if; - if S >= -Maxpow then - D_Val := D_Val / Powten (-S); + D_Val := D_Val / Powfive (-S); + + -- For small types, typically IEEE Single, the trick + -- described above does not fully work. + + elsif not Is_Large_Type and then S < -Maxexp then + D_Val := D_Val / Large_Powfive (-S, RS); + S := S - RS; + else - D_Val := D_Val / Large_Powten (-S); + D_Val := D_Val / Large_Powfive (-S); end if; end if; - R_Val := Double_Real.To_Single (D_Val); + R_Val := Num'Scaling (Double_Real.To_Single (D_Val), S); end; -- Implementation for other bases with exponentiation @@ -320,14 +315,26 @@ package body System.Val_Real is when Constraint_Error => Bad_Value (Str); end Integer_to_Real; - ------------------ - -- Large_Powten -- - ------------------ + ------------------- + -- Large_Powfive -- + ------------------- + + function Large_Powfive (Exp : Natural) return Double_T is + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; + + Powfive_100 : constant Double_T; + pragma Import (Ada, Powfive_100); + for Powfive_100'Address use Powfive_100_Address; + + Powfive_200 : constant Double_T; + pragma Import (Ada, Powfive_200); + for Powfive_200'Address use Powfive_200_Address; - function Large_Powten (Exp : Natural) return Double_T is - Powten : constant array (0 .. Maxpow) of Double_T; - pragma Import (Ada, Powten); - for Powten'Address use Powten_Address; + Powfive_300 : constant Double_T; + pragma Import (Ada, Powfive_300); + for Powfive_300'Address use Powfive_300_Address; R : Double_T; E : Natural; @@ -335,18 +342,80 @@ package body System.Val_Real is begin pragma Assert (Exp > Maxpow); - R := Powten (Maxpow); + if Is_Large_Type and then Exp >= 300 then + R := Powfive_300; + E := Exp - 300; + + elsif Is_Large_Type and then Exp >= 200 then + R := Powfive_200; + E := Exp - 200; + + elsif Is_Large_Type and then Exp >= 100 then + R := Powfive_100; + E := Exp - 100; + + else + R := Powfive (Maxpow); + E := Exp - Maxpow; + end if; + + while E > Maxpow loop + R := R * Powfive (Maxpow); + E := E - Maxpow; + end loop; + + R := R * Powfive (E); + + return R; + end Large_Powfive; + + function Large_Powfive (Exp : Natural; S : out Natural) return Double_T is + Maxexp : constant Positive := + (if Num'Size = 32 then Maxexp32 (5) + elsif Num'Size = 64 then Maxexp64 (5) + elsif Num'Machine_Mantissa = 64 then Maxexp80 (5) + else raise Program_Error); + -- Maximum exponent of 5 that can fit in Num + + Powfive : constant array (0 .. Maxpow) of Double_T; + pragma Import (Ada, Powfive); + for Powfive'Address use Powfive_Address; + + R : Double_T; + E : Natural; + + begin + pragma Assert (Exp > Maxexp); + + pragma Warnings (Off, "-gnatw.a"); + pragma Assert (not Is_Large_Type); + pragma Warnings (On, "-gnatw.a"); + + R := Powfive (Maxpow); E := Exp - Maxpow; + -- If the exponent is not too large, then scale down the result so that + -- its final value does not overflow but, if it's too large, then do not + -- bother doing it since overflow is just fine. The scaling factor is -3 + -- for every power of 5 above the maximum, in other words division by 8. + + if Exp - Maxexp <= Maxpow then + S := 3 * (Exp - Maxexp); + R.Hi := Num'Scaling (R.Hi, -S); + R.Lo := Num'Scaling (R.Lo, -S); + else + S := 0; + end if; + while E > Maxpow loop - R := R * Powten (Maxpow); + R := R * Powfive (Maxpow); E := E - Maxpow; end loop; - R := R * Powten (E); + R := R * Powfive (E); return R; - end Large_Powten; + end Large_Powfive; --------------- -- Scan_Real -- @@ -358,15 +427,15 @@ package body System.Val_Real is Max : Integer) return Num is Base : Unsigned; - Scale : Integer; + Scale : Impl.Scale_Array; Extra : Unsigned; Minus : Boolean; - Val : Uns; + Val : Impl.Value_Array; begin Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus); + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Scan_Real; ---------------- @@ -375,15 +444,15 @@ package body System.Val_Real is function Value_Real (Str : String) return Num is Base : Unsigned; - Scale : Integer; + Scale : Impl.Scale_Array; Extra : Unsigned; Minus : Boolean; - Val : Uns; + Val : Impl.Value_Array; begin Val := Impl.Value_Raw_Real (Str, Base, Scale, Extra, Minus); - return Integer_to_Real (Str, Val, Base, Scale, Extra, Minus); + return Integer_to_Real (Str, Val, Base, Scale, Minus); end Value_Real; end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads index 1d55fc9..89be8d7 100644 --- a/gcc/ada/libgnat/s-valrea.ads +++ b/gcc/ada/libgnat/s-valrea.ads @@ -38,7 +38,13 @@ generic Maxpow : Positive; - Powten_Address : System.Address; + Powfive_Address : System.Address; + + Powfive_100_Address : System.Address; + + Powfive_200_Address : System.Address; + + Powfive_300_Address : System.Address; type Uns is mod <>; diff --git a/gcc/ada/libgnat/s-valued.adb b/gcc/ada/libgnat/s-valued.adb index c4a78a2..92e9140 100644 --- a/gcc/ada/libgnat/s-valued.adb +++ b/gcc/ada/libgnat/s-valued.adb @@ -38,7 +38,7 @@ package body System.Value_D is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => False); + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => False); -- We do not use the Extra digit for decimal fixed-point types function Integer_to_Decimal @@ -229,16 +229,16 @@ package body System.Value_D is Max : Integer; Scale : Integer) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); end Scan_Decimal; ------------------- @@ -246,16 +246,16 @@ package body System.Value_D is ------------------- function Value_Decimal (Str : String; Scale : Integer) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); - return Integer_to_Decimal (Str, Val, Base, ScaleB, Minus, Scale); + return Integer_to_Decimal (Str, Val (1), Base, Scl (1), Minus, Scale); end Value_Decimal; end System.Value_D; diff --git a/gcc/ada/libgnat/s-valuef.adb b/gcc/ada/libgnat/s-valuef.adb index e252a28..1b9d18e 100644 --- a/gcc/ada/libgnat/s-valuef.adb +++ b/gcc/ada/libgnat/s-valuef.adb @@ -46,7 +46,7 @@ package body System.Value_F is pragma Assert (Int'Size <= Uns'Size); -- We need an unsigned type large enough to represent the mantissa - package Impl is new Value_R (Uns, 2**(Int'Size - 1), Round => True); + package Impl is new Value_R (Uns, 1, 2**(Int'Size - 1), Round => True); -- We use the Extra digit for ordinary fixed-point types function Integer_To_Fixed @@ -332,16 +332,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, ScaleB, Extra, Minus); + Val := Impl.Scan_Raw_Real (Str, Ptr, Max, Base, Scl, Extra, Minus); - return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + return + Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); end Scan_Fixed; ----------------- @@ -353,16 +354,17 @@ package body System.Value_F is Num : Int; Den : Int) return Int is - Base : Unsigned; - ScaleB : Integer; - Extra : Unsigned; - Minus : Boolean; - Val : Uns; + Base : Unsigned; + Scl : Impl.Scale_Array; + Extra : Unsigned; + Minus : Boolean; + Val : Impl.Value_Array; begin - Val := Impl.Value_Raw_Real (Str, Base, ScaleB, Extra, Minus); + Val := Impl.Value_Raw_Real (Str, Base, Scl, Extra, Minus); - return Integer_To_Fixed (Str, Val, Base, ScaleB, Extra, Minus, Num, Den); + return + Integer_To_Fixed (Str, Val (1), Base, Scl (1), Extra, Minus, Num, Den); end Value_Fixed; end System.Value_F; diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index fc91660..c55444a 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -44,22 +44,23 @@ package body System.Value_R is procedure Round_Extra (Digit : Char_As_Digit; + Base : Unsigned; Value : in out Uns; Scale : in out Integer; - Extra : in out Char_As_Digit; - Base : Unsigned); + Extra : in out Char_As_Digit); -- Round the triplet (Value, Scale, Extra) according to Digit in Base procedure Scan_Decimal_Digits (Str : String; Index : in out Integer; Max : Integer; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean); + Base_Specified : Boolean; + Value : in out Value_Array; + Scale : in out Scale_Array; + N : in out Positive; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean); -- Scan the decimal part of a real (i.e. after decimal separator) -- -- The string parsed is Str (Index .. Max) and after the call Index will @@ -77,12 +78,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : out Uns; - Scale : out Integer; - Extra : out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean); + Base_Specified : Boolean; + Value : out Value_Array; + Scale : out Scale_Array; + N : out Positive; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean); -- Scan the integral part of a real (i.e. before decimal separator) -- -- The string parsed is Str (Index .. Max) and after the call Index will @@ -123,10 +125,10 @@ package body System.Value_R is procedure Round_Extra (Digit : Char_As_Digit; + Base : Unsigned; Value : in out Uns; Scale : in out Integer; - Extra : in out Char_As_Digit; - Base : Unsigned) + Extra : in out Char_As_Digit) is pragma Assert (Base in 2 .. 16); @@ -145,7 +147,7 @@ package body System.Value_R is Extra := Char_As_Digit (Value mod B); Value := Value / B; Scale := Scale + 1; - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value, Scale, Extra); else Extra := 0; @@ -166,12 +168,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : in out Uns; - Scale : in out Integer; - Extra : in out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean) + Base_Specified : Boolean; + Value : in out Value_Array; + Scale : in out Scale_Array; + N : in out Positive; + Extra : in out Char_As_Digit; + Base_Violation : in out Boolean) is pragma Assert (Base in 2 .. 16); @@ -205,7 +208,7 @@ package body System.Value_R is -- If initial Scale is not 0 then it means that Precision_Limit was -- reached during scanning of the integral part. - if Scale > 0 then + if Scale (Data_Index'Last) > 0 then Precision_Limit_Reached := True; else Extra := 0; @@ -247,7 +250,7 @@ package body System.Value_R is if Precision_Limit_Reached then if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); Precision_Limit_Just_Reached := False; end if; @@ -258,19 +261,24 @@ package body System.Value_R is Trailing_Zeros := Trailing_Zeros + 1; else - -- Handle accumulated zeros. + -- Handle accumulated zeros for J in 1 .. Trailing_Zeros loop - if Value <= UmaxB then - Value := Value * Uns (Base); - Scale := Scale - 1; + if Value (N) <= UmaxB then + Value (N) := Value (N) * Uns (Base); + Scale (N) := Scale (N) - 1; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Scale (N) := Scale (N - 1) - 1; else Extra := 0; Precision_Limit_Reached := True; if Round and then J = Trailing_Zeros then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); end if; + exit; end if; end loop; @@ -281,7 +289,7 @@ package body System.Value_R is -- Handle current non zero digit - Temp := Value * Uns (Base) + Uns (Digit); + Temp := Value (N) * Uns (Base) + Uns (Digit); -- Precision_Limit_Reached may have been set above @@ -292,15 +300,20 @@ package body System.Value_R is -- account that Temp may wrap around when Precision_Limit is -- equal to the largest integer. - elsif Value <= Umax - or else (Value <= UmaxB + elsif Value (N) <= Umax + or else (Value (N) <= UmaxB and then ((Precision_Limit < Uns'Last and then Temp <= Precision_Limit) or else (Precision_Limit = Uns'Last and then Temp >= Uns (Base)))) then - Value := Temp; - Scale := Scale - 1; + Value (N) := Temp; + Scale (N) := Scale (N) - 1; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Value (N) := Uns (Digit); + Scale (N) := Scale (N - 1) - 1; else Extra := Digit; @@ -352,12 +365,13 @@ package body System.Value_R is (Str : String; Index : in out Integer; Max : Integer; - Value : out Uns; - Scale : out Integer; - Extra : out Char_As_Digit; - Base_Violation : in out Boolean; Base : Unsigned; - Base_Specified : Boolean) + Base_Specified : Boolean; + Value : out Value_Array; + Scale : out Scale_Array; + N : out Positive; + Extra : out Char_As_Digit; + Base_Violation : in out Boolean) is pragma Assert (Base in 2 .. 16); @@ -382,10 +396,11 @@ package body System.Value_R is -- Temporary begin - -- Initialize Value, Scale and Extra + -- Initialize N, Value, Scale and Extra - Value := 0; - Scale := 0; + N := 1; + Value := (others => 0); + Scale := (others => 0); Extra := 0; Precision_Limit_Reached := False; @@ -422,28 +437,32 @@ package body System.Value_R is -- should continue only to assess the validity of the string. if Precision_Limit_Reached then - Scale := Scale + 1; + Scale (N) := Scale (N) + 1; if Round and then Precision_Limit_Just_Reached then - Round_Extra (Digit, Value, Scale, Extra, Base); + Round_Extra (Digit, Base, Value (N), Scale (N), Extra); Precision_Limit_Just_Reached := False; end if; else - Temp := Value * Uns (Base) + Uns (Digit); + Temp := Value (N) * Uns (Base) + Uns (Digit); -- Check if Temp is larger than Precision_Limit, taking into -- account that Temp may wrap around when Precision_Limit is -- equal to the largest integer. - if Value <= Umax - or else (Value <= UmaxB + if Value (N) <= Umax + or else (Value (N) <= UmaxB and then ((Precision_Limit < Uns'Last and then Temp <= Precision_Limit) or else (Precision_Limit = Uns'Last and then Temp >= Uns (Base)))) then - Value := Temp; + Value (N) := Temp; + + elsif Parts > 1 and then N < Data_Index'Last then + N := N + 1; + Value (N) := Uns (Digit); else Extra := Digit; @@ -451,10 +470,16 @@ package body System.Value_R is if Round then Precision_Limit_Just_Reached := True; end if; - Scale := Scale + 1; + Scale (N) := Scale (N) + 1; end if; end if; + -- Every parsed digit also scales the previous parts + + for J in 1 .. N - 1 loop + Scale (J) := Scale (J) + 1; + end loop; + -- Look for the next character Index := Index + 1; @@ -492,9 +517,9 @@ package body System.Value_R is Ptr : not null access Integer; Max : Integer; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns + Minus : out Boolean) return Value_Array is pragma Assert (Max <= Str'Last); @@ -509,8 +534,11 @@ package body System.Value_R is -- If True some digits where not in the base. The real is still scanned -- till the end even if an error will be raised. + N : Positive; + -- Index number of the current part + Expon : Integer; - -- Exponent as an Integer + -- Exponent as an integer Index : Integer; -- Local copy of string pointer @@ -518,8 +546,8 @@ package body System.Value_R is Start : Positive; -- Index of the first non-blank character - Value : Uns; - -- Mantissa as an Integer + Value : Value_Array; + -- Mantissa as an array of integers begin -- The default base is 10 @@ -554,8 +582,8 @@ package body System.Value_R is -- part or the base to use. Scan_Integral_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => False); + (Str, Index, Max, Base, False, Value, Scale, N, + Char_As_Digit (Extra), Base_Violation); -- A dot is allowed only if followed by a digit (RM 3.5(47)) @@ -565,8 +593,9 @@ package body System.Value_R is then After_Point := True; Index := Index + 1; - Value := 0; - Scale := 0; + N := 1; + Value := (others => 0); + Scale := (others => 0); Extra := 0; else @@ -582,8 +611,8 @@ package body System.Value_R is then Base_Char := Str (Index); - if Value in 2 .. 16 then - Base := Unsigned (Value); + if N = 1 and then Value (1) in 2 .. 16 then + Base := Unsigned (Value (1)); else Base_Violation := True; Base := 16; @@ -597,7 +626,7 @@ package body System.Value_R is then After_Point := True; Index := Index + 1; - Value := 0; + Value := (others => 0); end if; end if; @@ -609,8 +638,8 @@ package body System.Value_R is end if; Scan_Integral_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Char_As_Digit (Extra), Base_Violation); end if; -- Do we have a dot? @@ -636,8 +665,8 @@ package body System.Value_R is pragma Assert (Index <= Max); Scan_Decimal_Digits - (Str, Index, Max, Value, Scale, Char_As_Digit (Extra), - Base_Violation, Base, Base_Specified => Base_Char /= ASCII.NUL); + (Str, Index, Max, Base, Base_Char /= ASCII.NUL, Value, Scale, + N, Char_As_Digit (Extra), Base_Violation); end if; -- If an explicit base was specified ensure that the delimiter is found @@ -660,9 +689,15 @@ package body System.Value_R is -- Handle very large exponents like Scan_Exponent if Expon < Integer'First / 10 or else Expon > Integer'Last / 10 then - Scale := Expon; + Scale (1) := Expon; + for J in 2 .. Data_Index'Last loop + Value (J) := 0; + end loop; + else - Scale := Scale + Expon; + for J in Data_Index'Range loop + Scale (J) := Scale (J) + Expon; + end loop; end if; -- Here is where we check for a bad based number @@ -672,7 +707,6 @@ package body System.Value_R is else return Value; end if; - end Scan_Raw_Real; -------------------- @@ -682,10 +716,13 @@ package body System.Value_R is function Value_Raw_Real (Str : String; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns + Minus : out Boolean) return Value_Array is + P : aliased Integer; + V : Value_Array; + begin -- We have to special case Str'Last = Positive'Last because the normal -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We @@ -697,20 +734,15 @@ package body System.Value_R is begin return Value_Raw_Real (NT (Str), Base, Scale, Extra, Minus); end; + end if; - -- Normal case where Str'Last < Positive'Last + -- Normal case - else - declare - V : Uns; - P : aliased Integer := Str'First; - begin - V := Scan_Raw_Real - (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; + P := Str'First; + V := Scan_Raw_Real (Str, P'Access, Str'Last, Base, Scale, Extra, Minus); + Scan_Trailing_Blanks (Str, P); + + return V; end Value_Raw_Real; end System.Value_R; diff --git a/gcc/ada/libgnat/s-valuer.ads b/gcc/ada/libgnat/s-valuer.ads index 3279090..d9d168e 100644 --- a/gcc/ada/libgnat/s-valuer.ads +++ b/gcc/ada/libgnat/s-valuer.ads @@ -37,22 +37,37 @@ with System.Unsigned_Types; use System.Unsigned_Types; generic type Uns is mod <>; + -- Modular type used for the value + + Parts : Positive; + -- Number of Uns parts in the value Precision_Limit : Uns; + -- Precision limit for each part of the value Round : Boolean; + -- If Parts = 1, True if the extra digit must be rounded package System.Value_R is pragma Preelaborate; + subtype Data_Index is Positive range 1 .. Parts; + -- The type indexing the value + + type Scale_Array is array (Data_Index) of Integer; + -- The scale for each part of the value + + type Value_Array is array (Data_Index) of Uns; + -- The value split into parts + function Scan_Raw_Real (Str : String; Ptr : not null access Integer; Max : Integer; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns; + Minus : out Boolean) return Value_Array; -- This function scans the string starting at Str (Ptr.all) for a valid -- real literal according to the syntax described in (RM 3.5(43)). The -- substring scanned extends no further than Str (Max). There are three @@ -64,9 +79,13 @@ package System.Value_R is -- parameters are set; if Val is the result of the call, then the real -- represented by the literal is equal to -- - -- (Val * Base + Extra) * (Base ** (Scale - 1)) + -- (Val (1) * Base + Extra) * (Base ** (Scale (1) - 1)) + -- + -- when Parts = 1 and + -- + -- Sum [Val (N) * (Base ** Scale (N)), N in 1 .. Parts] -- - -- with the negative sign if Minus is true. + -- when Parts > 1, with the negative sign if Minus is true. -- -- If no valid real is found, then Ptr.all points either to an initial -- non-blank character, or to Max + 1 if the field is all spaces and the @@ -91,9 +110,9 @@ package System.Value_R is function Value_Raw_Real (Str : String; Base : out Unsigned; - Scale : out Integer; + Scale : out Scale_Array; Extra : out Unsigned; - Minus : out Boolean) return Uns; + Minus : out Boolean) return Value_Array; -- Used in computing X'Value (Str) where X is a real type. Str is the -- string argument of the attribute. Constraint_Error is raised if the -- string is malformed. diff --git a/gcc/ada/libgnat/system-qnx-arm.ads b/gcc/ada/libgnat/system-qnx-arm.ads index 749384f..038fe6c 100644 --- a/gcc/ada/libgnat/system-qnx-arm.ads +++ b/gcc/ada/libgnat/system-qnx-arm.ads @@ -142,7 +142,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads index 46b740e..ae67cd0 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64-rtp-smp.ads @@ -151,7 +151,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-aarch64.ads b/gcc/ada/libgnat/system-vxworks7-aarch64.ads index 1aba15b..a943ecd 100644 --- a/gcc/ada/libgnat/system-vxworks7-aarch64.ads +++ b/gcc/ada/libgnat/system-vxworks7-aarch64.ads @@ -148,7 +148,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads index e81348e..49e6e7a 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads @@ -148,7 +148,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads index 4ced0f1..6d3218f4 100644 --- a/gcc/ada/libgnat/system-vxworks7-arm.ads +++ b/gcc/ada/libgnat/system-vxworks7-arm.ads @@ -146,7 +146,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads index 42ae983..e34c22a 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads @@ -146,7 +146,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads index 47dd3ae..68ca423 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads @@ -149,7 +149,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads index 7931241..6504a02 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads @@ -146,7 +146,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads index 3c98b4c..ffcc78f 100644 --- a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads @@ -149,7 +149,7 @@ private Stack_Check_Probes : constant Boolean := True; Stack_Check_Limits : constant Boolean := False; Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; Support_Composite_Assign : constant Boolean := True; Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 19a8b41..8f903ca 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -544,6 +544,13 @@ package Opt is -- Set to True to enable CUDA host expansion: -- - Removal of CUDA_Global and CUDA_Device symbols -- - Generation of kernel registration code in packages + -- - Binder invokes device elaboration/finalization code + + Enable_CUDA_Device_Expansion : Boolean := False; + -- GNATBIND + -- Set to True to enable CUDA device (as opposed to host) expansion: + -- - Binder generates elaboration/finalization code that can be + -- invoked from corresponding binder-generated host-side code. Error_Msg_Line_Length : Nat := 0; -- GNAT diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index 613be37..70fd7ad 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.adb @@ -279,10 +279,7 @@ package body Ch10 is Set_Private_Present (Comp_Unit_Node, True); end if; - elsif Token = Tok_Procedure - or else Token = Tok_Function - or else Token = Tok_Generic - then + elsif Token in Tok_Procedure | Tok_Function | Tok_Generic then Set_Private_Present (Comp_Unit_Node, True); end if; end if; @@ -300,8 +297,7 @@ package body Ch10 is -- Allow task and protected for nice error recovery purposes - exit when Token = Tok_Task - or else Token = Tok_Protected; + exit when Token in Tok_Task | Tok_Protected; if Token = Tok_With then Error_Msg_SC ("misplaced WITH"); @@ -376,10 +372,7 @@ package body Ch10 is elsif Token = Tok_Separate then Set_Unit (Comp_Unit_Node, P_Subunit); - elsif Token = Tok_Function - or else Token = Tok_Not - or else Token = Tok_Overriding - or else Token = Tok_Procedure + elsif Token in Tok_Function | Tok_Not | Tok_Overriding | Tok_Procedure then Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp)); @@ -392,10 +385,7 @@ package body Ch10 is if SIS_Entry_Active then - if Token = Tok_Begin - or else Token = Tok_Identifier - or else Token in Token_Class_Deckn - then + if Token in Tok_Begin | Tok_Identifier | Token_Class_Deckn then Push_Scope_Stack; Scopes (Scope.Last).Etyp := E_Name; Scopes (Scope.Last).Sloc := SIS_Sloc; @@ -947,10 +937,7 @@ package body Ch10 is Save_Scan_State (Scan_State); Scan; -- past comma - if Token in Token_Class_Cunit - or else Token = Tok_Use - or else Token = Tok_Pragma - then + if Token in Token_Class_Cunit | Tok_Use | Tok_Pragma then Restore_Scan_State (Scan_State); exit; end if; @@ -1047,11 +1034,7 @@ package body Ch10 is Ignore (Tok_Semicolon); - if Token = Tok_Function - or else Token = Tok_Not - or else Token = Tok_Overriding - or else Token = Tok_Procedure - then + if Token in Tok_Function | Tok_Not | Tok_Overriding | Tok_Procedure then Body_Node := P_Subprogram (Pf_Pbod_Pexp); elsif Token = Tok_Package then diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index fc76ad4..0f124f0 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -114,10 +114,7 @@ package body Ch12 is -- Check for generic renaming declaration case - if Token = Tok_Package - or else Token = Tok_Function - or else Token = Tok_Procedure - then + if Token in Tok_Package | Tok_Function | Tok_Procedure then Ren_Token := Token; Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index ca925d0..62e5807 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -336,7 +336,7 @@ package body Ch13 is -- Check for a missing aspect definition. Aspects with optional -- definitions are not considered. - if Token = Tok_Comma or else Token = Tok_Semicolon then + if Token in Tok_Comma | Tok_Semicolon then if not Opt then Error_Msg_Node_1 := Identifier (Aspect); Error_Msg_AP ("aspect& requires an aspect definition"); @@ -367,7 +367,7 @@ package body Ch13 is -- aspect Depends, Global, Refined_Depends, Refined_Global -- or Refined_State lacks enclosing parentheses. - if Token /= Tok_Left_Paren and then Token /= Tok_Null then + if Token not in Tok_Left_Paren | Tok_Null then -- [Refined_]Depends @@ -571,7 +571,7 @@ package body Ch13 is -- Attempt to detect ' or => following a potential aspect -- mark. - if Token = Tok_Apostrophe or else Token = Tok_Arrow then + if Token in Tok_Apostrophe | Tok_Arrow then Restore_Scan_State (Scan_State); Error_Msg_AP -- CODEFIX ("|missing "","""); @@ -603,7 +603,7 @@ package body Ch13 is -- Attempt to detect ' or => following potential aspect mark - if Token = Tok_Apostrophe or else Token = Tok_Arrow then + if Token in Tok_Apostrophe | Tok_Arrow then Restore_Scan_State (Scan_State); Error_Msg_SC -- CODEFIX ("|"";"" should be "","""); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 82df4cf..5684839 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -145,10 +145,7 @@ package body Ch3 is -- Here if := or something that we will take as equivalent - elsif Token = Tok_Colon_Equal - or else Token = Tok_Equal - or else Token = Tok_Is - then + elsif Token in Tok_Colon_Equal | Tok_Equal | Tok_Is then null; -- Another possibility. If we have a literal followed by a semicolon, @@ -400,9 +397,7 @@ package body Ch3 is -- Ada 2005 (AI-419): AARM 3.4 (2/2) if (Ada_Version < Ada_2005 and then Token = Tok_Limited) - or else Token = Tok_Private - or else Token = Tok_Record - or else Token = Tok_Null + or else Token in Tok_Private | Tok_Record | Tok_Null then Error_Msg_AP ("TAGGED expected"); end if; @@ -610,7 +605,7 @@ package body Ch3 is -- LIMITED RECORD or LIMITED NULL RECORD - if Token = Tok_Record or else Token = Tok_Null then + if Token in Tok_Record | Tok_Null then if Ada_Version = Ada_83 then Error_Msg_SP ("(Ada 83) limited record declaration not allowed!"); @@ -1005,7 +1000,7 @@ package body Ch3 is Type_Node : Node_Id; begin - if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + if Token in Tok_Identifier | Tok_Operator_Symbol then Type_Node := P_Subtype_Mark; return P_Subtype_Indication (Type_Node, Not_Null_Present); @@ -2095,10 +2090,7 @@ package body Ch3 is -- OK, not an aspect specification, so continue test for extension - elsif Token = Tok_With - or else Token = Tok_Record - or else Token = Tok_Null - then + elsif Token in Tok_With | Tok_Record | Tok_Null then T_With; -- past WITH or give error message if Token = Tok_Limited then @@ -2279,7 +2271,7 @@ package body Ch3 is -- Check for error of DIGITS or DELTA after a subtype mark - elsif Token = Tok_Digits or else Token = Tok_Delta then + elsif Token in Tok_Digits | Tok_Delta then Error_Msg_SC ("accuracy definition not allowed in membership test"); Scan; -- past DIGITS or DELTA @@ -2850,7 +2842,7 @@ package body Ch3 is Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr); end if; - exit when Token = Tok_Right_Paren or else Token = Tok_Of; + exit when Token in Tok_Right_Paren | Tok_Of; T_Comma; end loop; @@ -2865,7 +2857,7 @@ package body Ch3 is -- constrained_array_definition, which will be processed further below. elsif Prev_Token = Tok_Range - and then Token /= Tok_Right_Paren and then Token /= Tok_Comma + and then Token not in Tok_Right_Paren | Tok_Comma then -- If we have an expression followed by "..", then scan farther -- and check for "<>" to see if we have a fixed-lower-bound range. @@ -2920,7 +2912,7 @@ package body Ch3 is ("fixed-lower-bound array", Token_Ptr); end if; - exit when Token = Tok_Right_Paren or else Token = Tok_Of; + exit when Token in Tok_Right_Paren | Tok_Of; T_Comma; end loop; @@ -3382,7 +3374,7 @@ package body Ch3 is Save_Scan_State (Scan_State); -- at Id Scan; -- past Id - if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then + if Token in Tok_Arrow | Tok_Vertical_Bar then Restore_Scan_State (Scan_State); -- to Id Append (P_Discriminant_Association, Constr_List); goto Loop_Continue; @@ -3644,7 +3636,7 @@ package body Ch3 is -- If we have an END or WHEN now, everything is fine, otherwise we -- complain about the null, ignore it, and scan for more components. - if Token = Tok_End or else Token = Tok_When then + if Token in Tok_End | Tok_When then Set_Null_Present (Component_List_Node, True); return Component_List_Node; else @@ -3657,13 +3649,11 @@ package body Ch3 is P_Pragmas_Opt (Decls_List); if Token /= Tok_Case then - Component_Scan_Loop : loop + loop P_Component_Items (Decls_List); P_Pragmas_Opt (Decls_List); - exit Component_Scan_Loop when Token = Tok_End - or else Token = Tok_Case - or else Token = Tok_When; + exit when Token in Tok_End | Tok_Case | Tok_When; -- We are done if we do not have an identifier. However, if we -- have a misspelled reserved identifier that is in a column to @@ -3679,7 +3669,7 @@ package body Ch3 is Save_Scan_State (Scan_State); -- at reserved id Scan; -- possible reserved id - if Token = Tok_Comma or else Token = Tok_Colon then + if Token in Tok_Comma | Tok_Colon then Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => True); @@ -3688,16 +3678,16 @@ package body Ch3 is else Restore_Scan_State (Scan_State); - exit Component_Scan_Loop; + exit; end if; -- Non-identifier that definitely was not reserved id else - exit Component_Scan_Loop; + exit; end if; end if; - end loop Component_Scan_Loop; + end loop; end if; if Token = Tok_Case then @@ -3948,10 +3938,7 @@ package body Ch3 is loop P_Pragmas_Opt (Variants_List); - if Token /= Tok_When - and then Token /= Tok_If - and then Token /= Tok_Others - then + if Token not in Tok_When | Tok_If | Tok_Others then exit when Check_End; end if; @@ -4267,14 +4254,12 @@ package body Ch3 is Saved_State : Saved_Scan_State; begin - if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + if Token in Tok_Identifier | Tok_Operator_Symbol then Save_Scan_State (Saved_State); Scan; -- past possible junk subprogram name - if Token = Tok_Left_Paren or else Token = Tok_Semicolon then + if Token in Tok_Left_Paren | Tok_Semicolon then Error_Msg_SP ("unexpected subprogram name ignored"); - return; - else Restore_Scan_State (Saved_State); end if; @@ -4327,7 +4312,7 @@ package body Ch3 is if Prot_Flag then Scan; -- past PROTECTED - if Token /= Tok_Procedure and then Token /= Tok_Function then + if Token not in Tok_Procedure | Tok_Function then Error_Msg_SC -- CODEFIX ("FUNCTION or PROCEDURE expected"); end if; @@ -4402,7 +4387,7 @@ package body Ch3 is Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); Set_Null_Excluding_Subtype (Type_Def_Node, Not_Null_Subtype); - if Token = Tok_All or else Token = Tok_Constant then + if Token in Tok_All | Tok_Constant then if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) access modifier not allowed!"); end if; @@ -4472,10 +4457,7 @@ package body Ch3 is -- Ada 2005 (AI-254): Access_To_Subprogram_Definition - if Token = Tok_Protected - or else Token = Tok_Procedure - or else Token = Tok_Function - then + if Token in Tok_Protected | Tok_Procedure | Tok_Function then Error_Msg_Ada_2005_Extension ("access-to-subprogram"); Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True); @@ -4629,7 +4611,6 @@ package body Ch3 is end if; Done := True; - return; else Append (P_Representation_Clause, Decls); end if; @@ -4873,10 +4854,9 @@ package body Ch3 is -- If reserved identifier not followed by colon or comma, then -- this is most likely an assignment statement to the bad id. - if Token /= Tok_Colon and then Token /= Tok_Comma then + if Token not in Tok_Colon | Tok_Comma then Restore_Scan_State (Scan_State); Statement_When_Declaration_Expected (Decls, Done, In_Spec); - return; -- Otherwise we have a declaration of the bad id @@ -4892,7 +4872,6 @@ package body Ch3 is else Statement_When_Declaration_Expected (Decls, Done, In_Spec); - return; end if; -- The token RETURN may well also signal a missing BEGIN situation, @@ -4941,7 +4920,7 @@ package body Ch3 is Save_Scan_State (Scan_State); Scan; -- past the token - if Token /= Tok_Colon and then Token /= Tok_Comma then + if Token not in Tok_Colon | Tok_Comma then Restore_Scan_State (Scan_State); Set_Declaration_Expected; raise Error_Resync; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 9a00d7b..0dc6c8a 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -225,9 +225,7 @@ package body Ch4 is -- If it looks like start of expression, complain and scan expression - if Token in Token_Class_Literal - or else Token = Tok_Left_Paren - then + if Token in Token_Class_Literal | Tok_Left_Paren then Error_Msg_SC ("name expected"); return P_Expression; @@ -303,7 +301,7 @@ package body Ch4 is -- The treatment for the range attribute is similar (we do not -- consider x'range to be a name in this grammar). - elsif Token = Tok_Left_Paren or else Token = Tok_Range then + elsif Token in Tok_Left_Paren | Tok_Range then Restore_Scan_State (Scan_State); -- to apostrophe Expr_Form := EF_Simple_Name; return Name_Node; @@ -334,446 +332,449 @@ package body Ch4 is <<Scan_Name_Extension>> - -- Character literal used as name cannot be extended. Also this - -- cannot be a call, since the name for a call must be a designator. - -- Return in these cases, or if there is no name extension + -- Character literal used as name cannot be extended. Also this + -- cannot be a call, since the name for a call must be a designator. + -- Return in these cases, or if there is no name extension - if Token not in Token_Class_Namext - or else Prev_Token = Tok_Char_Literal - then - Expr_Form := EF_Name; - return Name_Node; - end if; + if Token not in Token_Class_Namext + or else Prev_Token = Tok_Char_Literal + then + Expr_Form := EF_Name; + return Name_Node; + end if; -- Merge here when we know there is a name extension <<Scan_Name_Extension_OK>> - if Token = Tok_Left_Paren then + case Token is + when Tok_Left_Paren => Scan; -- past left paren goto Scan_Name_Extension_Left_Paren; - elsif Token = Tok_Apostrophe then + when Tok_Apostrophe => Save_Scan_State (Scan_State); -- at apostrophe Scan; -- past apostrophe goto Scan_Name_Extension_Apostrophe; - else -- Token = Tok_Dot + when Tok_Dot => Save_Scan_State (Scan_State); -- at dot Scan; -- past dot goto Scan_Name_Extension_Dot; - end if; + + when others => raise Program_Error; + end case; -- Case of name extended by dot (selection), dot is already skipped -- and the scan state at the point of the dot is saved in Scan_State. <<Scan_Name_Extension_Dot>> - -- Explicit dereference case + -- Explicit dereference case - if Token = Tok_All then - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr); - Set_Prefix (Name_Node, Prefix_Node); - Scan; -- past ALL - goto Scan_Name_Extension; + if Token = Tok_All then + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Scan; -- past ALL + goto Scan_Name_Extension; -- Selected component case - elsif Token in Token_Class_Name then - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); - Set_Prefix (Name_Node, Prefix_Node); - Set_Selector_Name (Name_Node, Token_Node); - Scan; -- past selector - goto Scan_Name_Extension; + elsif Token in Token_Class_Name then + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + Scan; -- past selector + goto Scan_Name_Extension; -- Reserved identifier as selector - elsif Is_Reserved_Identifier then - Scan_Reserved_Identifier (Force_Msg => False); - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); - Set_Prefix (Name_Node, Prefix_Node); - Set_Selector_Name (Name_Node, Token_Node); - Scan; -- past identifier used as selector - goto Scan_Name_Extension; + elsif Is_Reserved_Identifier then + Scan_Reserved_Identifier (Force_Msg => False); + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); + Set_Prefix (Name_Node, Prefix_Node); + Set_Selector_Name (Name_Node, Token_Node); + Scan; -- past identifier used as selector + goto Scan_Name_Extension; -- If dot is at end of line and followed by nothing legal, -- then assume end of name and quit (dot will be taken as -- an incorrect form of some other punctuation by our caller). - elsif Token_Is_At_Start_Of_Line then - Restore_Scan_State (Scan_State); - return Name_Node; + elsif Token_Is_At_Start_Of_Line then + Restore_Scan_State (Scan_State); + return Name_Node; -- Here if nothing legal after the dot - else - Error_Msg_AP ("selector expected"); - raise Error_Resync; - end if; + else + Error_Msg_AP ("selector expected"); + raise Error_Resync; + end if; -- Here for an apostrophe as name extension. The scan position at the -- apostrophe has already been saved, and the apostrophe scanned out. <<Scan_Name_Extension_Apostrophe>> - Scan_Apostrophe : declare - function Apostrophe_Should_Be_Semicolon return Boolean; - -- Checks for case where apostrophe should probably be - -- a semicolon, and if so, gives appropriate message, - -- resets the scan pointer to the apostrophe, changes - -- the current token to Tok_Semicolon, and returns True. - -- Otherwise returns False. - - ------------------------------------ - -- Apostrophe_Should_Be_Semicolon -- - ------------------------------------ - - function Apostrophe_Should_Be_Semicolon return Boolean is - begin - if Token_Is_At_Start_Of_Line then - Restore_Scan_State (Scan_State); -- to apostrophe - Error_Msg_SC ("|""''"" should be "";"""); - Token := Tok_Semicolon; - return True; - else - return False; - end if; - end Apostrophe_Should_Be_Semicolon; + Scan_Apostrophe : declare + function Apostrophe_Should_Be_Semicolon return Boolean; + -- Checks for case where apostrophe should probably be + -- a semicolon, and if so, gives appropriate message, + -- resets the scan pointer to the apostrophe, changes + -- the current token to Tok_Semicolon, and returns True. + -- Otherwise returns False. - -- Start of processing for Scan_Apostrophe + ------------------------------------ + -- Apostrophe_Should_Be_Semicolon -- + ------------------------------------ + function Apostrophe_Should_Be_Semicolon return Boolean is begin - -- Check for qualified expression case in Ada 2012 mode + if Token_Is_At_Start_Of_Line then + Restore_Scan_State (Scan_State); -- to apostrophe + Error_Msg_SC ("|""''"" should be "";"""); + Token := Tok_Semicolon; + return True; + else + return False; + end if; + end Apostrophe_Should_Be_Semicolon; - if Ada_Version >= Ada_2012 - and then Token in Tok_Left_Paren | Tok_Left_Bracket - then - Name_Node := P_Qualified_Expression (Name_Node); - goto Scan_Name_Extension; + -- Start of processing for Scan_Apostrophe - -- If range attribute after apostrophe, then return with Token - -- pointing to the apostrophe. Note that in this case the prefix - -- need not be a simple name (cases like A.all'range). Similarly - -- if there is a left paren after the apostrophe, then we also - -- return with Token pointing to the apostrophe (this is the - -- aggregate case, or some error case). + begin + -- Check for qualified expression case in Ada 2012 mode - elsif Token = Tok_Range or else Token = Tok_Left_Paren then - Restore_Scan_State (Scan_State); -- to apostrophe - Expr_Form := EF_Name; - return Name_Node; + if Ada_Version >= Ada_2012 + and then Token in Tok_Left_Paren | Tok_Left_Bracket + then + Name_Node := P_Qualified_Expression (Name_Node); + goto Scan_Name_Extension; - -- Here for cases where attribute designator is an identifier + -- If range attribute after apostrophe, then return with Token + -- pointing to the apostrophe. Note that in this case the prefix + -- need not be a simple name (cases like A.all'range). Similarly + -- if there is a left paren after the apostrophe, then we also + -- return with Token pointing to the apostrophe (this is the + -- aggregate case, or some error case). - elsif Token = Tok_Identifier then - Attr_Name := Token_Name; + elsif Token in Tok_Range | Tok_Left_Paren then + Restore_Scan_State (Scan_State); -- to apostrophe + Expr_Form := EF_Name; + return Name_Node; - if not Is_Attribute_Name (Attr_Name) then - if Apostrophe_Should_Be_Semicolon then - Expr_Form := EF_Name; - return Name_Node; + -- Here for cases where attribute designator is an identifier - -- Here for a bad attribute name + elsif Token = Tok_Identifier then + Attr_Name := Token_Name; - else - Signal_Bad_Attribute; - Scan; -- past bad identifier + if not Is_Attribute_Name (Attr_Name) then + if Apostrophe_Should_Be_Semicolon then + Expr_Form := EF_Name; + return Name_Node; - if Token = Tok_Left_Paren then - Scan; -- past left paren + -- Here for a bad attribute name - loop - Discard_Junk_Node (P_Expression_If_OK); - exit when not Comma_Present; - end loop; + else + Signal_Bad_Attribute; + Scan; -- past bad identifier - T_Right_Paren; - end if; + if Token = Tok_Left_Paren then + Scan; -- past left paren - return Error; + loop + Discard_Junk_Node (P_Expression_If_OK); + exit when not Comma_Present; + end loop; + + T_Right_Paren; end if; - end if; - if Style_Check then - Style.Check_Attribute_Name (False); + return Error; end if; + end if; - -- Here for case of attribute designator is not an identifier + if Style_Check then + Style.Check_Attribute_Name (False); + end if; - else - if Token = Tok_Delta then - Attr_Name := Name_Delta; + -- Here for case of attribute designator is not an identifier - elsif Token = Tok_Digits then - Attr_Name := Name_Digits; + else + if Token = Tok_Delta then + Attr_Name := Name_Delta; - elsif Token = Tok_Access then - Attr_Name := Name_Access; + elsif Token = Tok_Digits then + Attr_Name := Name_Digits; - elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then - Attr_Name := Name_Mod; + elsif Token = Tok_Access then + Attr_Name := Name_Access; - elsif Apostrophe_Should_Be_Semicolon then - Expr_Form := EF_Name; - return Name_Node; + elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then + Attr_Name := Name_Mod; - else - Error_Msg_AP ("attribute designator expected"); - raise Error_Resync; - end if; + elsif Apostrophe_Should_Be_Semicolon then + Expr_Form := EF_Name; + return Name_Node; - if Style_Check then - Style.Check_Attribute_Name (True); - end if; + else + Error_Msg_AP ("attribute designator expected"); + raise Error_Resync; end if; - -- We come here with an OK attribute scanned, and corresponding - -- Attribute identifier node stored in Ident_Node. + if Style_Check then + Style.Check_Attribute_Name (True); + end if; + end if; - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); - Scan; -- past attribute designator - Set_Prefix (Name_Node, Prefix_Node); - Set_Attribute_Name (Name_Node, Attr_Name); + -- We come here with an OK attribute scanned, and corresponding + -- Attribute identifier node stored in Ident_Node. - -- Scan attribute arguments/designator. We skip this if we know - -- that the attribute cannot have an argument (see documentation - -- of Is_Parameterless_Attribute for further details). + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); + Scan; -- past attribute designator + Set_Prefix (Name_Node, Prefix_Node); + Set_Attribute_Name (Name_Node, Attr_Name); - if Token = Tok_Left_Paren - and then not - Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name)) - then - -- Attribute Update contains an array or record association - -- list which provides new values for various components or - -- elements. The list is parsed as an aggregate, and we get - -- better error handling by knowing that in the parser. + -- Scan attribute arguments/designator. We skip this if we know + -- that the attribute cannot have an argument (see documentation + -- of Is_Parameterless_Attribute for further details). - if Attr_Name = Name_Update then - Set_Expressions (Name_Node, New_List); - Append (P_Aggregate, Expressions (Name_Node)); + if Token = Tok_Left_Paren + and then not + Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name)) + then + -- Attribute Update contains an array or record association + -- list which provides new values for various components or + -- elements. The list is parsed as an aggregate, and we get + -- better error handling by knowing that in the parser. - -- All other cases of parsing attribute arguments + if Attr_Name = Name_Update then + Set_Expressions (Name_Node, New_List); + Append (P_Aggregate, Expressions (Name_Node)); - else - Set_Expressions (Name_Node, New_List); - Scan; -- past left paren - - loop - declare - Expr : constant Node_Id := P_Expression_If_OK; - Rnam : Node_Id; - - begin - -- Case of => for named notation - - if Token = Tok_Arrow then - - -- Named notation allowed only for the special - -- case of System'Restriction_Set (No_Dependence => - -- unit_NAME), in which case construct a parameter - -- assocation node and append to the arguments. - - if Attr_Name = Name_Restriction_Set - and then Nkind (Expr) = N_Identifier - and then Chars (Expr) = Name_No_Dependence - then - Scan; -- past arrow - Rnam := P_Name; - 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 - Error_Msg_SC - ("named parameters not permitted " - & "for attributes"); - Scan; -- past junk arrow - end if; - - -- Here for normal case (not => for named parameter) + -- All other cases of parsing attribute arguments + + else + Set_Expressions (Name_Node, New_List); + Scan; -- past left paren + + loop + declare + Expr : constant Node_Id := P_Expression_If_OK; + Rnam : Node_Id; + + begin + -- Case of => for named notation + + if Token = Tok_Arrow then + + -- Named notation allowed only for the special + -- case of System'Restriction_Set (No_Dependence => + -- unit_NAME), in which case construct a parameter + -- assocation node and append to the arguments. + + if Attr_Name = Name_Restriction_Set + and then Nkind (Expr) = N_Identifier + and then Chars (Expr) = Name_No_Dependence + then + Scan; -- past arrow + Rnam := P_Name; + 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 - -- Special handling for 'Image in Ada 2012, where - -- the attribute can be parameterless and its value - -- can be the prefix of a slice. Rewrite name as a - -- slice, Expr is its low bound. - - if Token = Tok_Dot_Dot - and then Attr_Name = Name_Image - and then Ada_Version >= Ada_2012 - then - Set_Expressions (Name_Node, No_List); - Prefix_Node := Name_Node; - Name_Node := - New_Node (N_Slice, Sloc (Prefix_Node)); - Set_Prefix (Name_Node, Prefix_Node); - Range_Node := New_Node (N_Range, Token_Ptr); - Set_Low_Bound (Range_Node, Expr); - Scan; -- past .. - Expr_Node := P_Expression; - Check_Simple_Expression (Expr_Node); - Set_High_Bound (Range_Node, Expr_Node); - Set_Discrete_Range (Name_Node, Range_Node); - T_Right_Paren; - - goto Scan_Name_Extension; - - else - Append (Expr, Expressions (Name_Node)); - exit when not Comma_Present; - end if; + Error_Msg_SC + ("named parameters not permitted " + & "for attributes"); + Scan; -- past junk arrow end if; - end; - end loop; - T_Right_Paren; - end if; + -- Here for normal case (not => for named parameter) + + else + -- Special handling for 'Image in Ada 2012, where + -- the attribute can be parameterless and its value + -- can be the prefix of a slice. Rewrite name as a + -- slice, Expr is its low bound. + + if Token = Tok_Dot_Dot + and then Attr_Name = Name_Image + and then Ada_Version >= Ada_2012 + then + Set_Expressions (Name_Node, No_List); + Prefix_Node := Name_Node; + Name_Node := + New_Node (N_Slice, Sloc (Prefix_Node)); + Set_Prefix (Name_Node, Prefix_Node); + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); + Set_Discrete_Range (Name_Node, Range_Node); + T_Right_Paren; + + goto Scan_Name_Extension; + + else + Append (Expr, Expressions (Name_Node)); + exit when not Comma_Present; + end if; + end if; + end; + end loop; + + T_Right_Paren; end if; + end if; - goto Scan_Name_Extension; - end Scan_Apostrophe; + goto Scan_Name_Extension; + end Scan_Apostrophe; -- Here for left parenthesis extending name (left paren skipped) <<Scan_Name_Extension_Left_Paren>> - -- We now have to scan through a list of items, terminated by a - -- right parenthesis. The scan is handled by a finite state - -- machine. The possibilities are: + -- We now have to scan through a list of items, terminated by a + -- right parenthesis. The scan is handled by a finite state + -- machine. The possibilities are: - -- (discrete_range) + -- (discrete_range) - -- This is a slice. This case is handled in LP_State_Init + -- This is a slice. This case is handled in LP_State_Init - -- (expression, expression, ..) + -- (expression, expression, ..) - -- This is interpreted as an indexed component, i.e. as a - -- case of a name which can be extended in the normal manner. - -- This case is handled by LP_State_Name or LP_State_Expr. + -- This is interpreted as an indexed component, i.e. as a + -- case of a name which can be extended in the normal manner. + -- This case is handled by LP_State_Name or LP_State_Expr. - -- Note: if and case expressions (without an extra level of - -- parentheses) are permitted in this context). + -- Note: if and case expressions (without an extra level of + -- parentheses) are permitted in this context). - -- (..., identifier => expression , ...) + -- (..., identifier => expression , ...) - -- If there is at least one occurrence of identifier => (but - -- none of the other cases apply), then we have a call. + -- If there is at least one occurrence of identifier => (but + -- none of the other cases apply), then we have a call. - -- Test for Id => case + -- Test for Id => case - if Token = Tok_Identifier then - Save_Scan_State (Scan_State); -- at Id - Scan; -- past Id + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id - -- Test for => (allow := as an error substitute) + -- Test for => (allow := as an error substitute) - if Token = Tok_Arrow or else Token = Tok_Colon_Equal then - Restore_Scan_State (Scan_State); -- to Id - Arg_List := New_List; - goto LP_State_Call; + if Token in Tok_Arrow | Tok_Colon_Equal then + Restore_Scan_State (Scan_State); -- to Id + Arg_List := New_List; + goto LP_State_Call; - else - Restore_Scan_State (Scan_State); -- to Id - end if; + else + Restore_Scan_State (Scan_State); -- to Id end if; + end if; - -- Here we have an expression after all - - Expr_Node := P_Expression_Or_Range_Attribute_If_OK; + -- Here we have an expression after all - -- Check cases of discrete range for a slice + Expr_Node := P_Expression_Or_Range_Attribute_If_OK; - -- First possibility: Range_Attribute_Reference + -- Check cases of discrete range for a slice - if Expr_Form = EF_Range_Attr then - Range_Node := Expr_Node; + -- First possibility: Range_Attribute_Reference - -- Second possibility: Simple_expression .. Simple_expression + if Expr_Form = EF_Range_Attr then + Range_Node := Expr_Node; - elsif Token = Tok_Dot_Dot then - Check_Simple_Expression (Expr_Node); - Range_Node := New_Node (N_Range, Token_Ptr); - Set_Low_Bound (Range_Node, Expr_Node); - Scan; -- past .. - Expr_Node := P_Expression; - Check_Simple_Expression (Expr_Node); - Set_High_Bound (Range_Node, Expr_Node); + -- Second possibility: Simple_expression .. Simple_expression - -- Third possibility: Type_name range Range + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Range_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Range_Node, Expr_Node); - elsif Token = Tok_Range then - if Expr_Form /= EF_Simple_Name then - Error_Msg_SC ("subtype mark must precede RANGE"); - raise Error_Resync; - end if; + -- Third possibility: Type_name range Range - Range_Node := P_Subtype_Indication (Expr_Node); + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("subtype mark must precede RANGE"); + raise Error_Resync; + end if; - -- Otherwise we just have an expression. It is true that we might - -- have a subtype mark without a range constraint but this case - -- is syntactically indistinguishable from the expression case. + Range_Node := P_Subtype_Indication (Expr_Node); - else - Arg_List := New_List; - goto LP_State_Expr; - end if; + -- Otherwise we just have an expression. It is true that we might + -- have a subtype mark without a range constraint but this case + -- is syntactically indistinguishable from the expression case. - -- Fall through here with unmistakable Discrete range scanned, - -- which means that we definitely have the case of a slice. The - -- Discrete range is in Range_Node. + else + Arg_List := New_List; + goto LP_State_Expr; + end if; - if Token = Tok_Comma then - Error_Msg_SC ("slice cannot have more than one dimension"); - raise Error_Resync; + -- Fall through here with unmistakable Discrete range scanned, + -- which means that we definitely have the case of a slice. The + -- Discrete range is in Range_Node. - elsif Token /= Tok_Right_Paren then - if Token = Tok_Arrow then + if Token = Tok_Comma then + Error_Msg_SC ("slice cannot have more than one dimension"); + raise Error_Resync; - -- This may be an aggregate that is missing a qualification + elsif Token /= Tok_Right_Paren then + if Token = Tok_Arrow then - Error_Msg_SC - ("context of aggregate must be a qualified expression"); - raise Error_Resync; + -- This may be an aggregate that is missing a qualification - else - T_Right_Paren; - raise Error_Resync; - end if; + Error_Msg_SC + ("context of aggregate must be a qualified expression"); + raise Error_Resync; else - Scan; -- past right paren - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Slice, Sloc (Prefix_Node)); - Set_Prefix (Name_Node, Prefix_Node); - Set_Discrete_Range (Name_Node, Range_Node); + T_Right_Paren; + raise Error_Resync; + end if; + + else + Scan; -- past right paren + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Slice, Sloc (Prefix_Node)); + Set_Prefix (Name_Node, Prefix_Node); + Set_Discrete_Range (Name_Node, Range_Node); - -- An operator node is legal as a prefix to other names, - -- but not for a slice. + -- An operator node is legal as a prefix to other names, + -- but not for a slice. - if Nkind (Prefix_Node) = N_Operator_Symbol then - Error_Msg_N ("illegal prefix for slice", Prefix_Node); - end if; + if Nkind (Prefix_Node) = N_Operator_Symbol then + Error_Msg_N ("illegal prefix for slice", Prefix_Node); + end if; - -- If we have a name extension, go scan it + -- If we have a name extension, go scan it - if Token in Token_Class_Namext then - goto Scan_Name_Extension_OK; + if Token in Token_Class_Namext then + goto Scan_Name_Extension_OK; - -- Otherwise return (a slice is a name, but is not a call) + -- Otherwise return (a slice is a name, but is not a call) - else - Expr_Form := EF_Name; - return Name_Node; - end if; + else + Expr_Form := EF_Name; + return Name_Node; end if; + end if; -- In LP_State_Expr, we have scanned one or more expressions, and -- so we have a call or an indexed component which is a name. On @@ -781,48 +782,48 @@ package body Ch4 is -- Arg_List contains the list of expressions encountered so far <<LP_State_Expr>> - Append (Expr_Node, Arg_List); + Append (Expr_Node, Arg_List); - if Token = Tok_Arrow then - Error_Msg - ("expect identifier in parameter association", Sloc (Expr_Node)); - Scan; -- past arrow + if Token = Tok_Arrow then + Error_Msg + ("expect identifier in parameter association", Sloc (Expr_Node)); + Scan; -- past arrow - elsif not Comma_Present then - T_Right_Paren; + elsif not Comma_Present then + T_Right_Paren; - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node)); - Set_Prefix (Name_Node, Prefix_Node); - Set_Expressions (Name_Node, Arg_List); + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node)); + Set_Prefix (Name_Node, Prefix_Node); + Set_Expressions (Name_Node, Arg_List); - goto Scan_Name_Extension; - end if; + goto Scan_Name_Extension; + end if; - -- Comma present (and scanned out), test for identifier => case - -- Test for identifier => case + -- Comma present (and scanned out), test for identifier => case + -- Test for identifier => case - if Token = Tok_Identifier then - Save_Scan_State (Scan_State); -- at Id - Scan; -- past Id + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id - -- Test for => (allow := as error substitute) + -- Test for => (allow := as error substitute) - if Token = Tok_Arrow or else Token = Tok_Colon_Equal then - Restore_Scan_State (Scan_State); -- to Id - goto LP_State_Call; + if Token in Tok_Arrow | Tok_Colon_Equal then + Restore_Scan_State (Scan_State); -- to Id + goto LP_State_Call; - -- Otherwise it's just an expression after all, so backup + -- Otherwise it's just an expression after all, so backup - else - Restore_Scan_State (Scan_State); -- to Id - end if; + else + Restore_Scan_State (Scan_State); -- to Id end if; + end if; - -- Here we have an expression after all, so stay in this state + -- Here we have an expression after all, so stay in this state - Expr_Node := P_Expression_If_OK; - goto LP_State_Expr; + Expr_Node := P_Expression_If_OK; + goto LP_State_Expr; -- LP_State_Call corresponds to the situation in which at least one -- instance of Id => Expression has been encountered, so we know that @@ -832,78 +833,78 @@ package body Ch4 is <<LP_State_Call>> - -- Test for case of Id => Expression (named parameter) + -- Test for case of Id => Expression (named parameter) - if Token = Tok_Identifier then - Save_Scan_State (Scan_State); -- at Id - Ident_Node := Token_Node; - Scan; -- past Id + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Ident_Node := Token_Node; + Scan; -- past Id - -- Deal with => (allow := as incorrect substitute) + -- Deal with => (allow := as incorrect substitute) - if Token = Tok_Arrow or else Token = Tok_Colon_Equal then - Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr); - Set_Selector_Name (Arg_Node, Ident_Node); - T_Arrow; - Set_Explicit_Actual_Parameter (Arg_Node, P_Expression); - Append (Arg_Node, Arg_List); + if Token in Tok_Arrow | Tok_Colon_Equal then + Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr); + Set_Selector_Name (Arg_Node, Ident_Node); + T_Arrow; + Set_Explicit_Actual_Parameter (Arg_Node, P_Expression); + Append (Arg_Node, Arg_List); - -- If a comma follows, go back and scan next entry + -- If a comma follows, go back and scan next entry - if Comma_Present then - goto LP_State_Call; + if Comma_Present then + goto LP_State_Call; - -- Otherwise we have the end of a call + -- Otherwise we have the end of a call - else - Prefix_Node := Name_Node; - Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node)); - Set_Name (Name_Node, Prefix_Node); - Set_Parameter_Associations (Name_Node, Arg_List); - T_Right_Paren; + else + Prefix_Node := Name_Node; + Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node)); + Set_Name (Name_Node, Prefix_Node); + Set_Parameter_Associations (Name_Node, Arg_List); + T_Right_Paren; - if Token in Token_Class_Namext then - goto Scan_Name_Extension_OK; + if Token in Token_Class_Namext then + goto Scan_Name_Extension_OK; - -- This is a case of a call which cannot be a name + -- This is a case of a call which cannot be a name - else - Expr_Form := EF_Name; - return Name_Node; - end if; + else + Expr_Form := EF_Name; + return Name_Node; end if; + end if; - -- Not named parameter: Id started an expression after all + -- Not named parameter: Id started an expression after all - else - Restore_Scan_State (Scan_State); -- to Id - end if; + else + Restore_Scan_State (Scan_State); -- to Id end if; + end if; - -- Here if entry did not start with Id => which means that it - -- is a positional parameter, which is not allowed, since we - -- have seen at least one named parameter already. + -- Here if entry did not start with Id => which means that it + -- is a positional parameter, which is not allowed, since we + -- have seen at least one named parameter already. - Error_Msg_SC - ("positional parameter association " & - "not allowed after named one"); + Error_Msg_SC + ("positional parameter association " & + "not allowed after named one"); - Expr_Node := P_Expression_If_OK; + Expr_Node := P_Expression_If_OK; - -- Leaving the '>' in an association is not unusual, so suggest - -- a possible fix. + -- Leaving the '>' in an association is not unusual, so suggest + -- a possible fix. - if Nkind (Expr_Node) = N_Op_Eq then - Error_Msg_N ("\maybe `='>` was intended", Expr_Node); - end if; + if Nkind (Expr_Node) = N_Op_Eq then + Error_Msg_N ("\maybe `='>` was intended", Expr_Node); + end if; - -- We go back to scanning out expressions, so that we do not get - -- multiple error messages when several positional parameters - -- follow a named parameter. + -- We go back to scanning out expressions, so that we do not get + -- multiple error messages when several positional parameters + -- follow a named parameter. - goto LP_State_Expr; + goto LP_State_Expr; - -- End of treatment for name extensions starting with left paren + -- End of treatment for name extensions starting with left paren -- End of loop through name extensions @@ -1384,7 +1385,7 @@ package body Ch4 is begin Save_Scan_State (Scan_State); Scan; -- past FOR - Maybe := Token = Tok_All or else Token = Tok_Some; + Maybe := Token in Tok_All | Tok_Some; Restore_Scan_State (Scan_State); -- to FOR return Maybe; end Is_Quantified_Expression; @@ -1609,11 +1610,8 @@ package body Ch4 is then Append_New (Expr_Node, Assoc_List); - elsif Token = Tok_Comma - or else Token = Tok_Right_Paren - or else Token = Tok_Others - or else Token in Token_Class_Lit_Or_Name - or else Token = Tok_Semicolon + elsif Token in Tok_Comma | Tok_Right_Paren | Tok_Others + | Token_Class_Lit_Or_Name | Tok_Semicolon then if Present (Assoc_List) then Error_Msg_BC -- CODEFIX @@ -1945,7 +1943,7 @@ package body Ch4 is -- Check for case of errant comma or semicolon - if Token = Tok_Comma or else Token = Tok_Semicolon then + if Token in Tok_Comma | Tok_Semicolon then declare Com : constant Boolean := Token = Tok_Comma; Scan_State : Saved_Scan_State; @@ -1959,7 +1957,7 @@ package body Ch4 is -- do not deal with AND/OR because those cases get mixed up -- with the select alternatives case. - if Token = Tok_And or else Token = Tok_Or then + if Token in Tok_And | Tok_Or then Logop := P_Logical_Operator; Restore_Scan_State (Scan_State); -- to comma/semicolon @@ -2008,11 +2006,7 @@ package body Ch4 is begin -- Case of conditional, case or quantified expression - if Token = Tok_Case - or else Token = Tok_If - or else Token = Tok_For - or else Token = Tok_Declare - then + if Token in Tok_Case | Tok_If | Tok_For | Tok_Declare then return P_Unparen_Cond_Expr_Etc; -- Normal case, not case/conditional/quantified expression @@ -2121,11 +2115,7 @@ package body Ch4 is begin -- Case of conditional, case or quantified expression - if Token = Tok_Case - or else Token = Tok_If - or else Token = Tok_For - or else Token = Tok_Declare - then + if Token in Tok_Case | Tok_If | Tok_For | Tok_Declare then return P_Unparen_Cond_Expr_Etc; -- Normal case, not one of the above expression types @@ -2967,7 +2957,7 @@ package body Ch4 is Save_Scan_State (Scan_State); Scan; -- past FOR - if Token = Tok_All or else Token = Tok_Some then + if Token in Tok_All | Tok_Some then Restore_Scan_State (Scan_State); -- To FOR Node1 := P_Quantified_Expression; @@ -3638,7 +3628,7 @@ package body Ch4 is Save_Scan_State (State); Scan; -- past semicolon - if Token = Tok_Else or else Token = Tok_Elsif then + if Token in Tok_Else | Tok_Elsif then Error_Msg_SP -- CODEFIX ("|extra "";"" ignored"); @@ -3837,7 +3827,7 @@ package body Ch4 is Save_Scan_State (Scan_State); Scan; -- past FOR - if Token = Tok_All or else Token = Tok_Some then + if Token in Tok_All | Tok_Some then Restore_Scan_State (Scan_State); Result := P_Quantified_Expression; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 1be3ef8..60b52bf 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -103,21 +103,11 @@ package body Ch5 is -- | LOOP_STATEMENT | BLOCK_STATEMENT -- | ACCEPT_STATEMENT | SELECT_STATEMENT - -- This procedure scans a sequence of statements. The caller sets SS_Flags - -- to indicate acceptable termination conditions for the sequence: - - -- SS_Flags.Eftm Terminate on ELSIF - -- SS_Flags.Eltm Terminate on ELSE - -- SS_Flags.Extm Terminate on EXCEPTION - -- SS_Flags.Ortm Terminate on OR - -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return) - -- SS_Flags.Whtm Terminate on WHEN - -- SS_Flags.Unco Unconditional terminate after scanning one statement - - -- In addition, the scan is always terminated by encountering END or the - -- end of file (EOF) condition. If one of the six above terminators is - -- encountered with the corresponding SS_Flags flag not set, then the - -- action taken is as follows: + -- This procedure scans a sequence of statements. SS_Flags indicates + -- termination conditions for the sequence. In addition, the sequence is + -- always terminated by encountering END or end of file. If one of the six + -- above terminators is encountered with the corresponding SS_Flags flag + -- not set, then the action taken is as follows: -- If the keyword occurs to the left of the expected column of the end -- for the current sequence (as recorded in the current end context), @@ -131,7 +121,8 @@ package body Ch5 is -- Note that the first action means that control can return to the caller -- with Token set to a terminator other than one of those specified by the - -- SS parameter. The caller should treat such a case as equivalent to END. + -- SS_Flags parameter. The caller should treat such a case as equivalent to + -- END. -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at -- least one real statement (other than a pragma) is required in the @@ -147,14 +138,14 @@ package body Ch5 is function P_Sequence_Of_Statements (SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id is - Statement_Required : Boolean; + Statement_Required : Boolean := SS_Flags.Sreq; -- This flag indicates if a subsequent statement (other than a pragma) -- is required. It is initialized from the Sreq flag, and modified as -- statements are scanned (a statement turns it off, and a label turns -- it back on again since a statement must follow a label). -- Note : this final requirement is lifted in Ada 2012. - Statement_Seen : Boolean; + Statement_Seen : Boolean := False; -- In Ada 2012, a label can end a sequence of statements, but the -- sequence cannot contain only labels. This flag is set whenever a -- label is encountered, to enforce this rule at the end of a sequence. @@ -162,7 +153,7 @@ package body Ch5 is Scan_State_Label : Saved_Scan_State; Scan_State : Saved_Scan_State; - Statement_List : List_Id; + Statement_List : constant List_Id := New_List; Block_Label : Name_Id; Id_Node : Node_Id; Name_Node : Node_Id; @@ -215,13 +206,7 @@ package body Ch5 is and then Statement_Seen) or else All_Pragmas) then - declare - Null_Stm : constant Node_Id := - Make_Null_Statement (Token_Ptr); - begin - Set_Comes_From_Source (Null_Stm, False); - Append_To (Statement_List, Null_Stm); - end; + null; -- If not Ada 2012, or not special case above, and no declaration -- seen (as allowed in Ada 2020), give error message. @@ -236,10 +221,6 @@ package body Ch5 is -- Start of processing for P_Sequence_Of_Statements begin - Statement_List := New_List; - Statement_Required := SS_Flags.Sreq; - Statement_Seen := False; - -- In Ada 2022, we allow declarative items to be mixed with -- statements. The loop below alternates between calling -- P_Declarative_Items to parse zero or more declarative items, @@ -270,7 +251,7 @@ package body Ch5 is end if; end; - begin + begin -- handle Error_Resync if Style_Check then Style.Check_Indentation; end if; @@ -290,18 +271,13 @@ package body Ch5 is -- with the exception of the cases tested for below. (Token = Tok_Semicolon - and then Prev_Token /= Tok_Return - and then Prev_Token /= Tok_Null - and then Prev_Token /= Tok_Raise - and then Prev_Token /= Tok_End - and then Prev_Token /= Tok_Exit) + and then Prev_Token not in + Tok_Return | Tok_Null | Tok_Raise | Tok_End | Tok_Exit) -- If followed by colon, colon-equal, or dot, then we -- definitely have an identifier (could not be reserved) - or else Token = Tok_Colon - or else Token = Tok_Colon_Equal - or else Token = Tok_Dot + or else Token in Tok_Colon | Tok_Colon_Equal | Tok_Dot -- Left paren means we have an identifier except for those -- reserved words that can legitimately be followed by a @@ -309,14 +285,9 @@ package body Ch5 is or else (Token = Tok_Left_Paren - and then Prev_Token /= Tok_Case - and then Prev_Token /= Tok_Delay - and then Prev_Token /= Tok_If - and then Prev_Token /= Tok_Elsif - and then Prev_Token /= Tok_Return - and then Prev_Token /= Tok_When - and then Prev_Token /= Tok_While - and then Prev_Token /= Tok_Separate) + and then Prev_Token not in + Tok_Case | Tok_Delay | Tok_If | Tok_Elsif | Tok_Return | + Tok_When | Tok_While | Tok_Separate) then -- Here we have an apparent reserved identifier and the -- token past it is appropriate to this usage (and would @@ -704,11 +675,12 @@ package body Ch5 is -- instance of an incorrectly spelled keyword. If so, we -- do nothing. The Bad_Spelling_Of will have reset Token -- to the appropriate keyword, so the next time round the - -- loop we will process the modified token. Note that we - -- check for ELSIF before ELSE here. That's not accidental. - -- We don't want to identify a misspelling of ELSE as - -- ELSIF, and in particular we do not want to treat ELSEIF - -- as ELSE IF. + -- loop we will process the modified token. + -- + -- Note that we check for ELSIF before ELSE here, because + -- we don't want to identify a misspelling of ELSE as ELSIF, + -- and in particular we do not want to treat ELSEIF as + -- ELSE IF. else Restore_Scan_State (Scan_State_Label); -- to identifier @@ -1452,7 +1424,7 @@ package body Ch5 is -- If we have a WHEN or OTHERS, then that's fine keep going. Note -- that it is a semantic check to ensure the proper use of OTHERS - if Token = Tok_When or else Token = Tok_Others then + if Token in Tok_When | Tok_Others then Append (P_Case_Statement_Alternative, Alternatives_List); -- If we have an END, then probably we are at the end of the case @@ -1764,7 +1736,7 @@ package body Ch5 is -- expression it is an iterator specification. Ambiguity is resolved -- during analysis of the loop parameter specification. - if Token = Tok_Of or else Token = Tok_Colon then + if Token in Tok_Of | Tok_Colon then Error_Msg_Ada_2012_Feature ("iterator", Token_Ptr); return P_Iterator_Specification (ID_Node); end if; @@ -2272,9 +2244,7 @@ package body Ch5 is -- END, EOF, or a token which starts declarations. elsif Parent_Nkind = N_Package_Body - and then (Token = Tok_End - or else Token = Tok_EOF - or else Token in Token_Class_Declk) + and then (Token in Tok_End | Tok_EOF | Token_Class_Declk) then Set_Null_HSS (Parent); @@ -2384,7 +2354,7 @@ package body Ch5 is TF_Then; end loop; - if Token = Tok_And or else Token = Tok_Or then + if Token in Tok_And | Tok_Or then Error_Msg_SC ("unexpected logical operator"); Scan; -- past logical operator diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 95fa937..4f06297 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -180,21 +180,6 @@ package body Ch6 is -- FUNCTION SPECIFICATION IS (EXPRESSION) -- [ASPECT_SPECIFICATIONS]; - -- The value in Pf_Flags indicates which of these possible declarations - -- is acceptable to the caller: - - -- Pf_Flags.Decl Set if declaration OK - -- Pf_Flags.Gins Set if generic instantiation OK - -- Pf_Flags.Pbod Set if proper body OK - -- Pf_Flags.Rnam Set if renaming declaration OK - -- Pf_Flags.Stub Set if body stub OK - -- Pf_Flags.Pexp Set if expression function OK - - -- If an inappropriate form is encountered, it is scanned out but an - -- error message indicating that it is appearing in an inappropriate - -- context is issued. The only possible values for Pf_Flags are those - -- defined as constants in the Par package. - -- The caller has checked that the initial token is FUNCTION, PROCEDURE, -- NOT or OVERRIDING. @@ -316,7 +301,7 @@ package body Ch6 is then Error_Msg_SC ("overriding indicator not allowed here!"); - elsif Token /= Tok_Function and then Token /= Tok_Procedure then + elsif Token not in Tok_Function | Tok_Procedure then Error_Msg_SC -- CODEFIX ("FUNCTION or PROCEDURE expected!"); end if; @@ -737,22 +722,15 @@ package body Ch6 is -- or a pragma, then we definitely have a subprogram body. -- This is a common case, so worth testing first. - if Token = Tok_Begin - or else Token in Token_Class_Declk - or else Token = Tok_Pragma - then + if Token in Tok_Begin | Token_Class_Declk | Tok_Pragma then return False; -- Test for tokens which could only start an expression and -- thus signal the case of a expression function. - elsif Token in Token_Class_Literal - or else Token in Token_Class_Unary_Addop - or else Token = Tok_Left_Paren - or else Token = Tok_Abs - or else Token = Tok_Null - or else Token = Tok_New - or else Token = Tok_Not + elsif Token in + Token_Class_Literal | Token_Class_Unary_Addop | + Tok_Left_Paren | Tok_Abs | Tok_Null | Tok_New | Tok_Not then null; @@ -1161,9 +1139,8 @@ package body Ch6 is Save_Scan_State (Scan_State); Scan; -- past dot - if Token = Tok_Identifier - or else Token = Tok_Operator_Symbol - or else Token = Tok_String_Literal + if Token in + Tok_Identifier | Tok_Operator_Symbol | Tok_String_Literal then return True; @@ -1180,8 +1157,7 @@ package body Ch6 is Ident_Node := Token_Node; Scan; -- past initial token - if Prev_Token = Tok_Operator_Symbol - or else Prev_Token = Tok_String_Literal + if Prev_Token in Tok_Operator_Symbol | Tok_String_Literal or else not Real_Dot then return Ident_Node; @@ -1216,7 +1192,7 @@ package body Ch6 is exception when Error_Resync => - while Token = Tok_Dot or else Token = Tok_Identifier loop + while Token in Tok_Dot | Tok_Identifier loop Scan; end loop; @@ -1327,7 +1303,7 @@ package body Ch6 is exception when Error_Resync => - while Token = Tok_Dot or else Token = Tok_Identifier loop + while Token in Tok_Dot | Tok_Identifier loop Scan; end loop; @@ -1462,10 +1438,8 @@ package body Ch6 is -- and on a right paren, e.g. Parms (X Y), and also -- on an assignment symbol, e.g. Parms (X Y := ..) - if Token = Tok_Semicolon - or else Token = Tok_Right_Paren - or else Token = Tok_EOF - or else Token = Tok_Colon_Equal + if Token in Tok_Semicolon | Tok_Right_Paren | + Tok_EOF | Tok_Colon_Equal then Restore_Scan_State (Scan_State); exit Ident_Loop; @@ -1474,9 +1448,7 @@ package body Ch6 is -- comma, e.g. Parms (A B : ...). Also assume a missing -- comma if we hit another comma, e.g. Parms (A B, C ..) - elsif Token = Tok_Colon - or else Token = Tok_Comma - then + elsif Token in Tok_Colon | Tok_Comma then Restore_Scan_State (Scan_State); exit Look_Ahead; end if; @@ -1551,7 +1523,7 @@ package body Ch6 is -- Case of IN or OUT present else - if Token = Tok_In or else Token = Tok_Out then + if Token in Tok_In | Tok_Out then if Not_Null_Present then Error_Msg ("`NOT NULL` can only be used with `ACCESS`", @@ -1627,7 +1599,7 @@ package body Ch6 is -- If we have RETURN or IS after the semicolon, then assume -- that semicolon should have been a right parenthesis and exit - if Token = Tok_Is or else Token = Tok_Return then + if Token in Tok_Is | Tok_Return then Error_Msg_SP -- CODEFIX ("|"";"" should be "")"""); exit Specification_Loop; diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index 71046e2..07c910a 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -71,21 +71,6 @@ package body Ch7 is -- new generic_package_NAME [GENERIC_ACTUAL_PART] -- [ASPECT_SPECIFICATIONS]; - -- The value in Pf_Flags indicates which of these possible declarations - -- is acceptable to the caller: - - -- Pf_Flags.Spcn Set if specification OK - -- Pf_Flags.Decl Set if declaration OK - -- Pf_Flags.Gins Set if generic instantiation OK - -- Pf_Flags.Pbod Set if proper body OK - -- Pf_Flags.Rnam Set if renaming declaration OK - -- Pf_Flags.Stub Set if body stub OK - - -- If an inappropriate form is encountered, it is scanned out but an error - -- message indicating that it is appearing in an inappropriate context is - -- issued. The only possible settings for Pf_Flags are those defined as - -- constants in package Par. - -- Note: in all contexts where a package specification is required, there -- is a terminating semicolon. This semicolon is scanned out in the case -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb index 67dce14..6e9139c 100644 --- a/gcc/ada/par-ch8.adb +++ b/gcc/ada/par-ch8.adb @@ -94,7 +94,7 @@ package body Ch8 is begin Scan; -- past USE - if Token = Tok_Type or else Token = Tok_All then + if Token in Tok_Type | Tok_All then P_Use_Type_Clause (Item_List); else P_Use_Package_Clause (Item_List); diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index 7d4ea62..310494e 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -343,10 +343,7 @@ package body Ch9 is -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING may begin an -- entry declaration. - elsif Token = Tok_Entry - or else Token = Tok_Not - or else Token = Tok_Overriding - then + elsif Token in Tok_Entry | Tok_Not | Tok_Overriding then Append (P_Entry_Declaration, Items); elsif Token = Tok_For then @@ -760,7 +757,7 @@ package body Ch9 is Set_Must_Override (Decl, Is_Overriding); Set_Must_Not_Override (Decl, Not_Overriding); - elsif Token = Tok_Function or else Token = Tok_Procedure then + elsif Token in Tok_Function | Tok_Procedure then Decl := P_Subprogram (Pf_Decl_Pexp); Set_Must_Override (Specification (Decl), Is_Overriding); @@ -987,7 +984,7 @@ package body Ch9 is -- If comma or colon after Id, must be Formal_Part - if Token = Tok_Comma or else Token = Tok_Colon then + if Token in Tok_Comma | Tok_Colon then Restore_Scan_State (Scan_State); -- to Id Set_Parameter_Specifications (Decl_Node, P_Formal_Part); @@ -1095,7 +1092,7 @@ package body Ch9 is -- If identifier followed by comma or colon, must be Formal_Part - if Token = Tok_Comma or else Token = Tok_Colon then + if Token in Tok_Comma | Tok_Colon then Restore_Scan_State (Scan_State); -- to left paren Set_Parameter_Specifications (Accept_Node, P_Parameter_Profile); diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb index 212d451..15b21cd 100644 --- a/gcc/ada/par-endh.adb +++ b/gcc/ada/par-endh.adb @@ -242,7 +242,7 @@ package body Endh is -- FOR or WHILE allowed (signalling error) to substitute for LOOP -- if on the same line as the END. - elsif (Token = Tok_For or else Token = Tok_While) + elsif Token in Tok_For | Tok_While and then not Token_Is_At_Start_Of_Line then Scan; -- past FOR or WHILE @@ -445,8 +445,7 @@ package body Endh is -- incorrect. Same thing for a period in place of a semicolon. elsif Token_Is_At_Start_Of_Line - or else Token = Tok_Colon - or else Token = Tok_Dot + or else Token in Tok_Colon | Tok_Dot then T_Semicolon; @@ -480,10 +479,8 @@ package body Endh is -- on the same line as the END while not Token_Is_At_Start_Of_Line - and then Prev_Token /= Tok_Record - and then Prev_Token /= Tok_Semicolon - and then Token /= Tok_End - and then Token /= Tok_EOF + and then Prev_Token not in Tok_Record | Tok_Semicolon + and then Token not in Tok_End | Tok_EOF loop Scan; -- past junk end loop; @@ -625,9 +622,8 @@ package body Endh is return; end if; - if Token /= Tok_Identifier - and then Token /= Tok_Operator_Symbol - and then Token /= Tok_String_Literal + if Token not in + Tok_Identifier | Tok_Operator_Symbol | Tok_String_Literal then exit; end if; @@ -655,9 +651,7 @@ package body Endh is -- if there is no line end at the end of the last line of the file) else - while Token /= Tok_End - and then Token /= Tok_EOF - and then Token /= Tok_Semicolon + while Token not in Tok_End | Tok_EOF | Tok_Semicolon and then not Token_Is_At_Start_Of_Line loop Scan; -- past junk token on same line @@ -1157,9 +1151,7 @@ package body Endh is Scan; -- past END - if Token = Tok_Identifier - or else Token = Tok_Operator_Symbol - then + if Token in Tok_Identifier | Tok_Operator_Symbol then Nxt_Labl := P_Designator; -- We only consider it an error if the label is a match diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb index 7a3da8e..570d229 100644 --- a/gcc/ada/par-sync.adb +++ b/gcc/ada/par-sync.adb @@ -58,9 +58,7 @@ package body Sync is begin Resync_Init; - while Token not in Token_Class_Cunit - and then Token /= Tok_EOF - loop + while Token not in Token_Class_Cunit | Tok_EOF loop Scan; end loop; @@ -92,9 +90,7 @@ package body Sync is or else (Paren_Count = 0 and then - (Token = Tok_Comma - or else Token = Tok_Right_Paren - or else Token = Tok_Vertical_Bar)) + Token in Tok_Comma | Tok_Right_Paren | Tok_Vertical_Bar) then -- A special check: if we stop on the ELSE of OR ELSE or the -- THEN of AND THEN, keep going, because this is not really an @@ -232,7 +228,7 @@ package body Sync is -- in this category only if it does NOT appear after WITH. elsif Token in Token_Class_After_SM - and then (Token /= Tok_Private or else Prev_Token /= Tok_With) + and then (Token /= Tok_Private or else Prev_Token /= Tok_With) then exit; @@ -274,7 +270,7 @@ package body Sync is -- Done if we are at THEN or LOOP - elsif Token = Tok_Then or else Token = Tok_Loop then + elsif Token in Tok_Then | Tok_Loop then exit; -- Otherwise keep going @@ -316,10 +312,7 @@ package body Sync is Paren_Count := 0; loop - if Token = Tok_EOF - or else Token = Tok_Semicolon - or else Token = Tok_Is - or else Token in Token_Class_After_SM + if Token in Tok_EOF | Tok_Semicolon | Tok_Is | Token_Class_After_SM then exit; @@ -386,10 +379,7 @@ package body Sync is loop -- Done if at semicolon, WHEN or IS - if Token = Tok_Semicolon - or else Token = Tok_When - or else Token = Tok_Is - then + if Token in Tok_Semicolon | Tok_When | Tok_Is then exit; -- Otherwise keep going diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb index 6a62d70..3989cd2 100644 --- a/gcc/ada/par-tchk.adb +++ b/gcc/ada/par-tchk.adb @@ -567,8 +567,7 @@ package body Tchk is loop if Prev_Token_Ptr < Current_Line_Start - or else Token = Tok_Semicolon - or else Token = Tok_EOF + or else Token in Tok_Semicolon | Tok_EOF then Restore_Scan_State (Scan_State); -- to where we were return; @@ -597,10 +596,7 @@ package body Tchk is -- Allow OF or => or = in place of IS (with error message) - elsif Token = Tok_Of - or else Token = Tok_Arrow - or else Token = Tok_Equal - then + elsif Token in Tok_Of | Tok_Arrow | Tok_Equal then T_Is; -- give missing IS message and skip bad token else @@ -609,8 +605,7 @@ package body Tchk is loop if Prev_Token_Ptr < Current_Line_Start - or else Token = Tok_Semicolon - or else Token = Tok_EOF + or else Token in Tok_Semicolon | Tok_EOF then Restore_Scan_State (Scan_State); -- to where we were return; @@ -618,10 +613,7 @@ package body Tchk is Scan; -- continue search - if Token = Tok_Is - or else Token = Tok_Of - or else Token = Tok_Arrow - then + if Token in Tok_Is | Tok_Of | Tok_Arrow then Scan; -- past IS or OF or => return; end if; @@ -642,7 +634,7 @@ package body Tchk is -- Allow DO or THEN in place of LOOP - elsif Token = Tok_Then or else Token = Tok_Do then + elsif Token in Tok_Then | Tok_Do then T_Loop; -- give missing LOOP message else @@ -651,8 +643,7 @@ package body Tchk is loop if Prev_Token_Ptr < Current_Line_Start - or else Token = Tok_Semicolon - or else Token = Tok_EOF + or else Token in Tok_Semicolon | Tok_EOF then Restore_Scan_State (Scan_State); -- to where we were return; @@ -660,7 +651,7 @@ package body Tchk is Scan; -- continue search - if Token = Tok_Loop or else Token = Tok_Then then + if Token in Tok_Loop | Tok_Then then Scan; -- past loop or then (message already generated) return; end if; @@ -686,8 +677,7 @@ package body Tchk is loop if Prev_Token_Ptr < Current_Line_Start - or else Token = Tok_Semicolon - or else Token = Tok_EOF + or else Token in Tok_Semicolon | Tok_EOF then Restore_Scan_State (Scan_State); -- to where we were return; @@ -752,8 +742,7 @@ package body Tchk is loop if Prev_Token_Ptr < Current_Line_Start - or else Token = Tok_EOF - or else Token = Tok_End + or else Token in Tok_EOF | Tok_End then Restore_Scan_State (Scan_State); -- to where we were return; @@ -789,8 +778,7 @@ package body Tchk is loop if Prev_Token_Ptr < Current_Line_Start - or else Token = Tok_Semicolon - or else Token = Tok_EOF + or else Token in Tok_Semicolon | Tok_EOF then Restore_Scan_State (Scan_State); -- to where we were return; @@ -823,8 +811,7 @@ package body Tchk is loop if Prev_Token_Ptr < Current_Line_Start - or else Token = Tok_Semicolon - or else Token = Tok_EOF + or else Token in Tok_Semicolon | Tok_EOF then Restore_Scan_State (Scan_State); -- to where we were return; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 3f1247a..0387418 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -336,7 +336,7 @@ package body Util is -- probably the semicolon did end the list. Indeed that is -- certainly the only single error correction possible here. - if Token = Tok_Semicolon or else Token = Tok_EOF then + if Token in Tok_Semicolon | Tok_EOF then Restore_Scan_State (Scan_State); return False; @@ -521,44 +521,34 @@ package body Util is raise Program_Error; when C_Comma_Right_Paren => - OK_Next_Tok := - Token = Tok_Comma or else Token = Tok_Right_Paren; + OK_Next_Tok := Token in Tok_Comma | Tok_Right_Paren; when C_Comma_Colon => - OK_Next_Tok := - Token = Tok_Comma or else Token = Tok_Colon; + OK_Next_Tok := Token in Tok_Comma | Tok_Colon; when C_Do => - OK_Next_Tok := - Token = Tok_Do; + OK_Next_Tok := Token = Tok_Do; when C_Dot => - OK_Next_Tok := - Token = Tok_Dot; + OK_Next_Tok := Token = Tok_Dot; when C_Greater_Greater => - OK_Next_Tok := - Token = Tok_Greater_Greater; + OK_Next_Tok := Token = Tok_Greater_Greater; when C_In => - OK_Next_Tok := - Token = Tok_In; + OK_Next_Tok := Token = Tok_In; when C_Is => - OK_Next_Tok := - Token = Tok_Is; + OK_Next_Tok := Token = Tok_Is; when C_Left_Paren_Semicolon => - OK_Next_Tok := - Token = Tok_Left_Paren or else Token = Tok_Semicolon; + OK_Next_Tok := Token in Tok_Left_Paren | Tok_Semicolon; when C_Use => - OK_Next_Tok := - Token = Tok_Use; + OK_Next_Tok := Token = Tok_Use; when C_Vertical_Bar_Arrow => - OK_Next_Tok := - Token = Tok_Vertical_Bar or else Token = Tok_Arrow; + OK_Next_Tok := Token in Tok_Vertical_Bar | Tok_Arrow; end case; Restore_Scan_State (Scan_State); @@ -802,7 +792,7 @@ package body Util is function Token_Is_At_Start_Of_Line return Boolean is begin - return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF); + return Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF; end Token_Is_At_Start_Of_Line; ----------------------------------- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index b6ffdae..01e3c4b 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -361,36 +361,29 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is Expr_Form : Expr_Form_Type; - -- The following type is used for calls to P_Subprogram, P_Package, P_Task, - -- P_Protected to indicate which of several possibilities is acceptable. + -- The following type is used by P_Subprogram, P_Package, to indicate which + -- of several possibilities is acceptable. type Pf_Rec is record - Spcn : Boolean; -- True if specification OK - Decl : Boolean; -- True if declaration OK - Gins : Boolean; -- True if generic instantiation OK - Pbod : Boolean; -- True if proper body OK - Rnam : Boolean; -- True if renaming declaration OK - Stub : Boolean; -- True if body stub OK - Pexp : Boolean; -- True if parameterized expression OK - Fil2 : Boolean; -- Filler to fill to 8 bits + Spcn : Boolean; -- True if specification OK + Decl : Boolean; -- True if declaration OK + Gins : Boolean; -- True if generic instantiation OK + Pbod : Boolean; -- True if proper body OK + Rnam : Boolean; -- True if renaming declaration OK + Stub : Boolean; -- True if body stub OK + Pexp : Boolean; -- True if parameterized expression OK end record; pragma Pack (Pf_Rec); function T return Boolean renames True; function F return Boolean renames False; - Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec := - Pf_Rec'(F, T, T, T, T, T, T, F); - Pf_Decl_Pexp : constant Pf_Rec := - Pf_Rec'(F, T, F, F, F, F, T, F); - Pf_Decl_Gins_Pbod_Rnam_Pexp : constant Pf_Rec := - Pf_Rec'(F, T, T, T, T, F, T, F); - Pf_Decl_Pbod_Pexp : constant Pf_Rec := - Pf_Rec'(F, T, F, T, F, F, T, F); - Pf_Pbod_Pexp : constant Pf_Rec := - Pf_Rec'(F, F, F, T, F, F, T, F); - Pf_Spcn : constant Pf_Rec := - Pf_Rec'(T, F, F, F, F, F, F, F); + Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp : constant Pf_Rec := (F, T, T, T, T, T, T); + Pf_Decl_Pexp : constant Pf_Rec := (F, T, F, F, F, F, T); + Pf_Decl_Gins_Pbod_Rnam_Pexp : constant Pf_Rec := (F, T, T, T, T, F, T); + Pf_Decl_Pbod_Pexp : constant Pf_Rec := (F, T, F, T, F, F, T); + Pf_Pbod_Pexp : constant Pf_Rec := (F, F, F, T, F, F, T); + Pf_Spcn : constant Pf_Rec := (T, F, F, F, F, F, F); -- The above are the only allowed values of Pf_Rec arguments type SS_Rec is record @@ -405,15 +398,15 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is end record; pragma Pack (SS_Rec); - SS_Eftm_Eltm_Sreq : constant SS_Rec := SS_Rec'(T, T, F, F, T, F, F, F); - SS_Eltm_Ortm_Tatm : constant SS_Rec := SS_Rec'(F, T, F, T, F, T, F, F); - SS_Extm_Sreq : constant SS_Rec := SS_Rec'(F, F, T, F, T, F, F, F); - SS_None : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, F); - SS_Ortm_Sreq : constant SS_Rec := SS_Rec'(F, F, F, T, T, F, F, F); - SS_Sreq : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, F, F); - SS_Sreq_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, T, F); - SS_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F); - SS_Unco : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T); + SS_Eftm_Eltm_Sreq : constant SS_Rec := (T, T, F, F, T, F, F, F); + SS_Eltm_Ortm_Tatm : constant SS_Rec := (F, T, F, T, F, T, F, F); + SS_Extm_Sreq : constant SS_Rec := (F, F, T, F, T, F, F, F); + SS_None : constant SS_Rec := (F, F, F, F, F, F, F, F); + SS_Ortm_Sreq : constant SS_Rec := (F, F, F, T, T, F, F, F); + SS_Sreq : constant SS_Rec := (F, F, F, F, T, F, F, F); + SS_Sreq_Whtm : constant SS_Rec := (F, F, F, F, T, F, T, F); + SS_Whtm : constant SS_Rec := (F, F, F, F, F, F, T, F); + SS_Unco : constant SS_Rec := (F, F, F, F, F, F, F, T); Goto_List : Elist_Id; -- List of goto nodes appearing in the current compilation. Used to @@ -882,9 +875,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Sequence_Of_Statements (SS_Flags : SS_Rec; Handled : Boolean := False) return List_Id; - -- The argument indicates the acceptable termination tokens. - -- See body in Par.Ch5 for details of the use of this parameter. - -- Handled is true if we are parsing a handled sequence of statements. + -- SS_Flags indicates the acceptable termination tokens; see body for + -- details. Handled is true if we are parsing a handled sequence of + -- statements. procedure Parse_Decls_Begin_End (Parent : Node_Id); -- Parses declarations and handled statement sequence, setting diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb index b67fe8d..6731bae 100644 --- a/gcc/ada/prep.adb +++ b/gcc/ada/prep.adb @@ -461,11 +461,8 @@ package body Prep is -- Handle relational operator - elsif Token = Tok_Equal - or else Token = Tok_Less - or else Token = Tok_Less_Equal - or else Token = Tok_Greater - or else Token = Tok_Greater_Equal + elsif Token in Tok_Equal | Tok_Less | Tok_Less_Equal | + Tok_Greater | Tok_Greater_Equal then Relop := Token; Scan.all; @@ -771,9 +768,7 @@ package body Prep is begin -- Scan until we get an end of line or we reach the end of the buffer - while Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - loop + while Token not in Tok_End_Of_Line | Tok_EOF loop Scan.all; end loop; end Go_To_End_Of_Line; @@ -1042,7 +1037,7 @@ package body Prep is Scan.all; - if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then + if Token not in Tok_End_Of_Line | Tok_EOF then Error_Msg ("extraneous text in definition", Token_Ptr); goto Cleanup; end if; @@ -1056,12 +1051,12 @@ package body Prep is Scan.all; - if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then + if Token not in Tok_End_Of_Line | Tok_EOF then Error_Msg ("extraneous text in definition", Token_Ptr); goto Cleanup; end if; - elsif Token = Tok_End_Of_Line or else Token = Tok_EOF then + elsif Token in Tok_End_Of_Line | Tok_EOF then Data := (Symbol => Symbol_Name, Original => Original_Name, On_The_Command_Line => False, @@ -1093,7 +1088,7 @@ package body Prep is Scan.all; - if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then + if Token not in Tok_End_Of_Line | Tok_EOF then Error_Msg ("extraneous text in definition", Token_Ptr); goto Cleanup; end if; @@ -1144,7 +1139,7 @@ package body Prep is <<Cleanup>> Set_Ignore_Errors (To => True); - while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop + while Token not in Tok_End_Of_Line | Tok_EOF loop Scan.all; end loop; @@ -1261,9 +1256,7 @@ package body Prep is -- It is an error to have trailing characters after -- the condition or "then". - if Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - then + if Token not in Tok_End_Of_Line | Tok_EOF then Error_Msg ("extraneous text on preprocessor line", Token_Ptr); @@ -1318,9 +1311,7 @@ package body Prep is -- It is an error to have trailing characters after the -- condition or "then". - if Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - then + if Token not in Tok_End_Of_Line | Tok_EOF then Error_Msg ("extraneous text on preprocessor line", Token_Ptr); @@ -1384,9 +1375,7 @@ package body Prep is -- Error of character present after "#else" - if Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - then + if Token not in Tok_End_Of_Line | Tok_EOF then Error_Msg ("extraneous text on preprocessor line", Token_Ptr); @@ -1427,9 +1416,7 @@ package body Prep is -- Error of character present after "#end if;" - if Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - then + if Token not in Tok_End_Of_Line | Tok_EOF then Error_Msg ("extraneous text on preprocessor line", Token_Ptr); @@ -1496,9 +1483,7 @@ package body Prep is Go_To_End_Of_Line; else - while Token /= Tok_End_Of_Line - and then Token /= Tok_EOF - loop + while Token not in Tok_End_Of_Line | Tok_EOF loop if Token = Tok_Special and then Special_Character = '$' then @@ -1564,7 +1549,7 @@ package body Prep is end if; end if; - pragma Assert (Token = Tok_End_Of_Line or else Token = Tok_EOF); + pragma Assert (Token in Tok_End_Of_Line | Tok_EOF); -- At this point, the token is either end of line or EOF. The line to -- possibly output stops just before the token. diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb index 3cd2959..a1fe025 100644 --- a/gcc/ada/prepcomp.adb +++ b/gcc/ada/prepcomp.adb @@ -311,7 +311,7 @@ package body Prepcomp is -- Check the switches that may follow - while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop + while Token not in Tok_End_Of_Line | Tok_EOF loop if Token /= Tok_Minus then Error_Msg -- CODEFIX ("`'-` expected", Token_Ptr); @@ -755,7 +755,7 @@ package body Prepcomp is begin Set_Ignore_Errors (To => True); - while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop + while Token not in Tok_End_Of_Line | Tok_EOF loop Scan; end loop; diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index f5fc020..b6698a6 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -1747,15 +1747,9 @@ package body Scng is -- In Ada 2022, a target name (i.e. @) is a valid prefix of an -- attribute, and functions like a name. - if Prev_Token = Tok_All - or else Prev_Token = Tok_At_Sign - or else Prev_Token = Tok_Delta - or else Prev_Token = Tok_Digits - or else Prev_Token = Tok_Identifier - or else Prev_Token = Tok_Project - or else Prev_Token = Tok_Right_Paren - or else Prev_Token = Tok_Right_Bracket - or else Prev_Token in Token_Class_Literal + if Prev_Token in Tok_All | Tok_At_Sign | Tok_Delta | Tok_Digits | + Tok_Identifier | Tok_Project | Tok_Right_Paren | + Tok_Right_Bracket | Token_Class_Literal then Token := Tok_Apostrophe; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index fa3e9bf..5c7633b 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -32,7 +32,7 @@ -- Analysis implements the bulk of semantic analysis such as -- name analysis and type resolution for declarations, --- instructions and expressions. The main routine +-- statements, and expressions. The main routine -- driving this process is procedure Analyze given below. -- This analysis phase is really a bottom up pass that is -- achieved during the recursive traversal performed by the @@ -46,26 +46,25 @@ -- completed during analysis (because of overloading -- ambiguities). Specifically, after completing the bottom -- up pass carried out during analysis for expressions, the --- Resolve routine (see the spec of sem_res for more info) +-- Resolve routine (see the spec of Sem_Res for more info) -- is called to perform a top down resolution with -- recursive calls to itself to resolve operands. --- Expansion if we are not generating code this phase is a no-op. +-- Expansion If we are not generating code this phase is a no-op. -- Otherwise this phase expands, i.e. transforms, original --- declaration, expressions or instructions into simpler --- structures that can be handled by the back-end. This --- phase is also in charge of generating code which is --- implicit in the original source (for instance for --- default initializations, controlled types, etc.) --- There are two separate instances where expansion is +-- source constructs into simpler constructs that can be +-- handled by the back-end. This phase is also in charge of +-- generating code which is implicit in the original source +-- (for instance for default initializations, controlled types, +-- etc.) There are two separate instances where expansion is -- invoked. For declarations and instructions, expansion is --- invoked just after analysis since no resolution needs --- to be performed. For expressions, expansion is done just --- after resolution. In both cases expansion is done from the --- bottom up just before the end of Analyze for instructions --- and declarations or the call to Resolve for expressions. --- The main routine driving expansion is Expand. --- See the spec of Expander for more details. +-- invoked just after analysis since no resolution needs to be +-- performed. For expressions, expansion is done just after +-- resolution. In both cases expansion is done from the bottom +-- up just before the end of Analyze for instructions and +-- declarations or the call to Resolve for expressions. The +-- main routine driving expansion is Expand. See the spec of +-- Expander for more details. -- To summarize, in normal code generation mode we recursively traverse the -- abstract syntax tree top-down performing semantic analysis bottom @@ -110,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 Analyze_Spec_Expression. +-- special analysis is called Preanalyze_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 @@ -134,7 +133,7 @@ -- of the expression cannot be obtained at the point of declaration, only at -- the point of use. --- Generally our model is to combine analysis resolution and expansion, but +-- Generally our model is to combine analysis, resolution, and expansion, but -- this is the one case where this model falls down. Here is how we patch -- it up without causing too much distortion to our basic model. @@ -175,7 +174,7 @@ -- children is performed before expansion of the parent does not work if the -- code generated for the children by the expander needs to be evaluated -- repeatedly (for instance in the above aggregate "new Thing (Function_Call)" --- needs to be called 100 times.) +-- needs to be called 100 times). -- The reason this mechanism does not work is that the expanded code for the -- children is typically inserted above the parent and thus when the parent diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 258e4ad..5db1fce 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1987,6 +1987,11 @@ package body Sem_Aggr is while Present (Assoc) loop if Nkind (Assoc) = N_Iterated_Component_Association then Resolve_Iterated_Component_Association (Assoc, Index_Typ); + + elsif Nkind (Assoc) /= N_Component_Association then + Error_Msg_N + ("invalid component association for aggregate", Assoc); + return Failure; end if; Choice := First (Choice_List (Assoc)); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 93bb6f4..0c88be7 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1430,12 +1430,11 @@ package body Sem_Attr is Placement_Error; end if; - -- 'Old attribute reference ok in a _Postconditions procedure + -- 'Old attribute reference ok in a _Wrapped_Statements procedure elsif Nkind (Prag) = N_Subprogram_Body - and then not Comes_From_Source (Prag) - and then Nkind (Corresponding_Spec (Prag)) = N_Defining_Identifier - and then Chars (Corresponding_Spec (Prag)) = Name_uPostconditions + and then Ekind (Defining_Entity (Prag)) in Subprogram_Kind + and then Present (Wrapped_Statements (Defining_Entity (Prag))) then null; @@ -1450,18 +1449,18 @@ package body Sem_Attr is if Nkind (Prag) = N_Aspect_Specification then Subp_Decl := Parent (Prag); elsif Nkind (Prag) = N_Subprogram_Body then - declare - Enclosing_Scope : constant Node_Id := - Scope (Corresponding_Spec (Prag)); - begin - pragma Assert (Postconditions_Proc (Enclosing_Scope) - = Corresponding_Spec (Prag)); - Subp_Decl := Parent (Parent (Enclosing_Scope)); - end; + Subp_Decl := Prag; else Subp_Decl := Find_Related_Declaration_Or_Body (Prag); end if; + -- 'Old objects appear in block statements as part of the expansion + -- of contract wrappers. + + if Nkind (Subp_Decl) = N_Block_Statement then + Subp_Decl := Parent (Parent (Subp_Decl)); + end if; + -- The aspect or pragma where the attribute resides should be -- associated with a subprogram declaration or a body. If this is not -- the case, then the aspect or pragma is illegal. Return as analysis @@ -1506,7 +1505,7 @@ package body Sem_Attr is if Modify_Tree_For_C and then Chars (Spec_Id) = Name_uParent - and then Chars (Scope (Spec_Id)) = Name_uPostconditions + and then Chars (Scope (Spec_Id)) = Name_uWrapped_Statements then -- This situation occurs only when analyzing the body-to-inline @@ -1750,7 +1749,7 @@ package body Sem_Attr is if Is_Entry_Wrapper (Spec_Id) then Legal := True; - elsif Chars (Spec_Id) = Name_uPostconditions + elsif Chars (Spec_Id) = Name_uWrapped_Statements and then Is_Entry_Wrapper (Scope (Spec_Id)) then Spec_Id := Scope (Spec_Id); @@ -4697,19 +4696,6 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); - --------------- - -- Lock_Free -- - --------------- - - when Attribute_Lock_Free => - Check_E0; - Set_Etype (N, Standard_Boolean); - - if not Is_Protected_Type (P_Type) then - Error_Attr_P - ("prefix of % attribute must be a protected object"); - end if; - ---------------- -- Loop_Entry -- ---------------- @@ -5894,13 +5880,13 @@ package body Sem_Attr is Error_Attr ("prefix of % attribute must be a function", P); end if; - -- Attribute 'Result is part of a _Postconditions procedure. There is + -- Attribute 'Result is part of postconditions expansion. There is -- no need to perform the semantic checks below as they were already -- verified when the attribute was analyzed in its original context. -- Instead, rewrite the attribute as a reference to formal parameter - -- _Result of the _Postconditions procedure. + -- _Result of the _Wrapped_Statements procedure. - if Chars (Spec_Id) = Name_uPostconditions + if Chars (Spec_Id) = Name_uWrapped_Statements or else (In_Inlined_C_Postcondition and then Nkind (Parent (Spec_Id)) = N_Block_Statement) @@ -7413,10 +7399,19 @@ package body Sem_Attr is if Comes_From_Source (N) then Check_Object_Reference (P); + -- Attribute 'Valid_Scalars is illegal on unchecked union types + -- regardles of the privacy, because it is not always guaranteed + -- that the components are retrievable based on whether the + -- discriminants are inferable. + + if Has_Unchecked_Union (Validated_View (P_Type)) then + Error_Attr_P + ("attribute % not allowed for Unchecked_Union type"); + -- Do not emit any diagnostics related to private types to avoid -- disclosing the structure of the type. - if Is_Private_Type (P_Type) then + elsif Is_Private_Type (P_Type) then -- Attribute 'Valid_Scalars is not supported on private tagged -- types due to a code generation issue. Is_Visible_Component @@ -7446,15 +7441,6 @@ package body Sem_Attr is ("??attribute % always True, no scalars to check", P); Set_Boolean_Result (N, True); end if; - - -- Attribute 'Valid_Scalars is illegal on unchecked union types - -- because it is not always guaranteed that the components are - -- retrievable based on whether the discriminants are inferable - - if Has_Unchecked_Union (P_Type) then - Error_Attr_P - ("attribute % not allowed for Unchecked_Union type"); - end if; end if; end if; @@ -8338,15 +8324,6 @@ package body Sem_Attr is return; - -- For Lock_Free, we apply the attribute to the type of the object. - -- This is allowed since we have already verified that the type is a - -- protected type. - - elsif Id = Attribute_Lock_Free then - P_Entity := Etype (P); - - -- No other attributes for objects are folded - else Check_Expressions; return; @@ -8476,7 +8453,6 @@ package body Sem_Attr is Id = Attribute_Has_Access_Values or else Id = Attribute_Has_Discriminants or else Id = Attribute_Has_Tagged_Values or else - Id = Attribute_Lock_Free or else Id = Attribute_Preelaborable_Initialization or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array or else @@ -8595,7 +8571,7 @@ package body Sem_Attr is -- only the First, Last and Length attributes are possibly static. -- Atomic_Always_Lock_Free, Definite, Descriptor_Size, Has_Access_Values - -- Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and + -- Has_Discriminants, Has_Tagged_Values, Type_Class, and -- Unconstrained_Array are again exceptions, because they apply as well -- to unconstrained types. @@ -8614,7 +8590,6 @@ package body Sem_Attr is Id = Attribute_Has_Access_Values or else Id = Attribute_Has_Discriminants or else Id = Attribute_Has_Tagged_Values or else - Id = Attribute_Lock_Free or else Id = Attribute_Preelaborable_Initialization or else Id = Attribute_Type_Class or else Id = Attribute_Unconstrained_Array or else @@ -9315,24 +9290,6 @@ package body Sem_Attr is True); end if; - --------------- - -- Lock_Free -- - --------------- - - when Attribute_Lock_Free => Lock_Free : declare - V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type)); - - begin - Rewrite (N, New_Occurrence_Of (V, Loc)); - - -- Analyze and resolve as boolean. Note that this attribute is a - -- static attribute in GNAT. - - Analyze_And_Resolve (N, Standard_Boolean); - Static := True; - Set_Is_Static_Expression (N); - end Lock_Free; - ---------- -- Last -- ---------- diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 0bb358a..2810d3e 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -106,6 +106,14 @@ package body Sem_Case is package Composite_Case_Ops is + Simplified_Composite_Coverage_Rules : constant Boolean := True; + -- Indicates that, as a temporary stopgap, we implement + -- simpler coverage-checking rules when casing on a + -- composite selector: + -- 1) Require that an Others choice must be given, regardless + -- of whether all possible values are covered explicitly. + -- 2) No legality checks regarding overlapping choices. + function Box_Value_Required (Subtyp : Entity_Id) return Boolean; -- If result is True, then the only allowed value (in a choice -- aggregate) for a component of this (sub)type is a box. This rule @@ -263,7 +271,6 @@ package body Sem_Case is type Bound_Values is array (Positive range <>) of Node_Id; end Choice_Analysis; - end Composite_Case_Ops; procedure Expand_Others_Choice @@ -2526,6 +2533,14 @@ package body Sem_Case is for P in Part_Id loop Insert_Representative (Component_Bounds (P).Low, P); end loop; + + if Simplified_Composite_Coverage_Rules then + -- Omit other representative values to avoid capacity + -- problems building data structures only used in + -- compile-time checks that will not be performed. + return Result; + end if; + for C of Choices_Bounds loop if not C.Is_Others then for P in Part_Id loop @@ -3368,8 +3383,6 @@ package body Sem_Case is -------------------------------- procedure Check_Case_Pattern_Choices is - -- ??? Need to Free/Finalize value sets allocated here. - package Ops is new Composite_Case_Ops.Choice_Analysis (Case_Statement => N); use Ops; @@ -3394,8 +3407,14 @@ package body Sem_Case is Covered : Value_Set := Empty; -- The union of all alternatives seen so far - begin + if Composite_Case_Ops.Simplified_Composite_Coverage_Rules then + if not (for some Choice of Info => Choice.Is_Others) then + Error_Msg_N ("others choice required", N); + end if; + return; + end if; + for Choice of Info loop if Choice.Is_Others then Others_Seen := True; diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index a15fd09..339edd3 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -49,7 +49,6 @@ with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; -with Snames; use Snames; with Stand; use Stand; package body Sem_Ch11 is @@ -431,12 +430,10 @@ package body Sem_Ch11 is -- If the current scope is a subprogram, entry or task body or declare -- block then this is the right place to check for hanging useless - -- assignments from the statement sequence. Skip this in the body of a - -- postcondition, since in that case there are no source references. + -- assignments from the statement sequence. - if (Is_Subprogram_Or_Entry (Current_Scope) - and then Chars (Current_Scope) /= Name_uPostconditions) - or else Ekind (Current_Scope) in E_Block | E_Task_Type + if Is_Subprogram_Or_Entry (Current_Scope) + or else Ekind (Current_Scope) in E_Block | E_Task_Type then Warn_On_Useless_Assignments (Current_Scope); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 4d1644b..54b10dd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2293,7 +2293,7 @@ package body Sem_Ch13 is then Error_Msg_Name_1 := Nam; Error_Msg_N - ("expression of aspect %" & + ("expression of aspect % " & "must be static", Aspect); end if; @@ -6959,6 +6959,7 @@ package body Sem_Ch13 is if Nkind (Expr) /= N_Aggregate then Error_Msg_N ("aspect Iterable must be an aggregate", Expr); + return; end if; declare @@ -6969,7 +6970,9 @@ package body Sem_Ch13 is while Present (Assoc) loop Analyze (Expression (Assoc)); - if not Is_Entity_Name (Expression (Assoc)) then + if not Is_Entity_Name (Expression (Assoc)) + or else Ekind (Entity (Expression (Assoc))) /= E_Function + then Error_Msg_N ("value must be a function", Assoc); end if; @@ -15875,22 +15878,34 @@ package body Sem_Ch13 is Ent := Entity (N); F1 := First_Formal (Ent); + F2 := Next_Formal (F1); - if Nam in Name_First | Name_Last then + if Nam = Name_First then - -- First or Last (Container) => Cursor + -- First (Container) => Cursor if Etype (Ent) /= Cursor then Error_Msg_N ("primitive for First must yield a cursor", N); + elsif Present (F2) then + Error_Msg_N ("no match for First iterable primitive", N); + end if; + + elsif Nam = Name_Last then + + -- Last (Container) => Cursor + + if Etype (Ent) /= Cursor then + Error_Msg_N ("primitive for Last must yield a cursor", N); + elsif Present (F2) then + Error_Msg_N ("no match for Last iterable primitive", N); end if; elsif Nam = Name_Next then -- Next (Container, Cursor) => Cursor - F2 := Next_Formal (F1); - - if Etype (F2) /= Cursor + if No (F2) + or else Etype (F2) /= Cursor or else Etype (Ent) /= Cursor or else Present (Next_Formal (F2)) then @@ -15901,9 +15916,8 @@ package body Sem_Ch13 is -- Previous (Container, Cursor) => Cursor - F2 := Next_Formal (F1); - - if Etype (F2) /= Cursor + if No (F2) + or else Etype (F2) /= Cursor or else Etype (Ent) /= Cursor or else Present (Next_Formal (F2)) then @@ -15914,9 +15928,8 @@ package body Sem_Ch13 is -- Has_Element (Container, Cursor) => Boolean - F2 := Next_Formal (F1); - - if Etype (F2) /= Cursor + if No (F2) + or else Etype (F2) /= Cursor or else Etype (Ent) /= Standard_Boolean or else Present (Next_Formal (F2)) then @@ -15924,7 +15937,8 @@ package body Sem_Ch13 is end if; elsif Nam = Name_Element then - F2 := Next_Formal (F1); + + -- Element (Container, Cursor) => Element_Type; if No (F2) or else Etype (F2) /= Cursor @@ -17084,34 +17098,41 @@ package body Sem_Ch13 is ------------------------------ procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id) is + Aggr : constant Node_Id := Expression (ASN); Assoc : Node_Id; Expr : Node_Id; Prim : Node_Id; - Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ); + Cursor : Entity_Id; - First_Id : Entity_Id; - Last_Id : Entity_Id; - Next_Id : Entity_Id; - Has_Element_Id : Entity_Id; - Element_Id : Entity_Id; + First_Id : Entity_Id := Empty; + Last_Id : Entity_Id := Empty; + Next_Id : Entity_Id := Empty; + Has_Element_Id : Entity_Id := Empty; + Element_Id : Entity_Id := Empty; begin + if Nkind (Aggr) /= N_Aggregate then + Error_Msg_N ("aspect Iterable must be an aggregate", Aggr); + return; + end if; + + Cursor := Get_Cursor_Type (ASN, Typ); + -- If previous error aspect is unusable if Cursor = Any_Type then return; end if; - First_Id := Empty; - Last_Id := Empty; - Next_Id := Empty; - Has_Element_Id := Empty; - Element_Id := Empty; + if not Is_Empty_List (Expressions (Aggr)) then + Error_Msg_N + ("illegal positional association", First (Expressions (Aggr))); + end if; -- Each expression must resolve to a function with the proper signature - Assoc := First (Component_Associations (Expression (ASN))); + Assoc := First (Component_Associations (Aggr)); while Present (Assoc) loop Expr := Expression (Assoc); Analyze (Expr); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index ed2f621..ceaf66b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -4798,7 +4798,7 @@ package body Sem_Ch4 is Name : constant Node_Id := Prefix (N); Sel : constant Node_Id := Selector_Name (N); Act_Decl : Node_Id; - Comp : Entity_Id; + Comp : Entity_Id := Empty; Has_Candidate : Boolean := False; Hidden_Comp : Entity_Id; In_Scope : Boolean; @@ -4814,6 +4814,14 @@ package body Sem_Ch4 is Is_Single_Concurrent_Object : Boolean; -- Set True if the prefix is a single task or a single protected object + function Constraint_Has_Unprefixed_Discriminant_Reference + (Typ : Entity_Id) return Boolean; + -- Given a subtype that is subject to a discriminant-dependent + -- constraint, returns True if any of the values of the constraint + -- (i.e., any of the index values for an index constraint, any of + -- the discriminant values for a discriminant constraint) + -- are unprefixed discriminant names. + procedure Find_Component_In_Instance (Rec : Entity_Id); -- In an instance, a component of a private extension may not be visible -- while it was visible in the generic. Search candidate scope for a @@ -4842,6 +4850,56 @@ package body Sem_Ch4 is -- _Procedure, and collect all its interpretations (since it may be an -- overloaded interface primitive); otherwise return False. + ------------------------------------------------------ + -- Constraint_Has_Unprefixed_Discriminant_Reference -- + ------------------------------------------------------ + + function Constraint_Has_Unprefixed_Discriminant_Reference + (Typ : Entity_Id) return Boolean + is + + function Is_Discriminant_Name (N : Node_Id) return Boolean is + ((Nkind (N) = N_Identifier) + and then (Ekind (Entity (N)) = E_Discriminant)); + begin + if Is_Array_Type (Typ) then + declare + Index : Node_Id := First_Index (Typ); + Rng : Node_Id; + begin + while Present (Index) loop + Rng := Index; + if Nkind (Rng) = N_Subtype_Indication then + Rng := Range_Expression (Constraint (Rng)); + end if; + + if Nkind (Rng) = N_Range then + if Is_Discriminant_Name (Low_Bound (Rng)) + or else Is_Discriminant_Name (High_Bound (Rng)) + then + return True; + end if; + end if; + + Next_Index (Index); + end loop; + end; + else + declare + Elmt : Elmt_Id := First_Elmt (Discriminant_Constraint (Typ)); + begin + while Present (Elmt) loop + if Is_Discriminant_Name (Node (Elmt)) then + return True; + end if; + Next_Elmt (Elmt); + end loop; + end; + end if; + + return False; + end Constraint_Has_Unprefixed_Discriminant_Reference; + -------------------------------- -- Find_Component_In_Instance -- -------------------------------- @@ -5129,7 +5187,16 @@ package body Sem_Ch4 is and then not Is_Derived_Type (Prefix_Type) and then Is_Entity_Name (Name); - Comp := First_Entity (Type_To_Use); + -- Avoid initializing Comp if that initialization is not needed + -- (and, more importantly, if the call to First_Entity could fail). + + if Has_Discriminants (Type_To_Use) + or else Is_Record_Type (Type_To_Use) + or else Is_Private_Type (Type_To_Use) + or else Is_Concurrent_Type (Type_To_Use) + then + Comp := First_Entity (Type_To_Use); + end if; -- If the selector has an original discriminant, the node appears in -- an instance. Replace the discriminant with the corresponding one @@ -5289,6 +5356,33 @@ package body Sem_Ch4 is end; end if; + -- If Etype (Comp) is an access type whose designated subtype + -- is constrained by an unprefixed discriminant value, + -- then ideally we would build a new subtype with an + -- appropriately prefixed discriminant value and use that + -- instead, as is done in Build_Actual_Subtype_Of_Component. + -- That turns out to be difficult in this context (with + -- Full_Analysis = False, we could be processing a selected + -- component that occurs in a Postcondition pragma; + -- PPC pragmas are odd because they can contain references + -- to formal parameters that occur outside the subprogram). + -- So instead we punt on building a new subtype and we + -- use the base type instead. This might introduce + -- correctness problems if N were the target of an + -- assignment (because a required check might be omitted); + -- fortunately, that's impossible because a reference to the + -- current instance of a type does not denote a variable view + -- when the reference occurs within an aspect_specification. + -- GNAT's Precondition and Postcondition pragmas follow the + -- same rules as a Pre or Post aspect_specification. + + elsif Has_Discriminant_Dependent_Constraint (Comp) + and then Ekind (Etype (Comp)) = E_Access_Subtype + and then Constraint_Has_Unprefixed_Discriminant_Reference + (Designated_Type (Etype (Comp))) + then + Set_Etype (N, Base_Type (Etype (Comp))); + -- If Full_Analysis not enabled, just set the Etype else diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7240129..0459058 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1911,15 +1911,19 @@ package body Sem_Ch6 is Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); end if; - Analyze_Declarations (Declarations (N)); - Check_Completion; - - -- Process the contract of the subprogram body after all declarations - -- have been analyzed. This ensures that any contract-related pragmas - -- are available through the N_Contract node of the body. + -- Process the contract of the subprogram body after analyzing all + -- the contract-related pragmas within the declarations. + Analyze_Pragmas_In_Declarations (Body_Id); Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id); + -- Continue on with analyzing the declarations and statements once + -- contract expansion is done and we are done expanding contract + -- related wrappers. + + Analyze_Declarations (Declarations (N)); + Check_Completion; + Analyze (Handled_Statement_Sequence (N)); Save_Global_References (Original_Node (N)); @@ -2032,7 +2036,7 @@ package body Sem_Ch6 is end loop; -- Determine whether the null procedure may be a completion of a generic - -- suprogram, in which case we use the new null body as the completion + -- subprogram, in which case we use the new null body as the completion -- and set minimal semantic information on the original declaration, -- which is rewritten as a null statement. @@ -2895,7 +2899,6 @@ package body Sem_Ch6 is Conformant : Boolean; Desig_View : Entity_Id := Empty; Exch_Views : Elist_Id := No_Elist; - HSS : Node_Id; Mask_Types : Elist_Id := No_Elist; Prot_Typ : Entity_Id := Empty; Spec_Decl : Node_Id := Empty; @@ -3530,6 +3533,8 @@ package body Sem_Ch6 is -------------------------- procedure Check_Missing_Return is + HSS : constant Node_Id := Handled_Statement_Sequence (N); + Id : Entity_Id; Missing_Ret : Boolean; @@ -3968,18 +3973,9 @@ package body Sem_Ch6 is -- Move relevant pragmas to the spec - elsif Pragma_Name_Unmapped (Decl) in Name_Depends - | Name_Ghost - | Name_Global - | Name_Pre - | Name_Precondition - | Name_Post - | Name_Refined_Depends - | Name_Refined_Global - | Name_Refined_Post - | Name_Inline - | Name_Pure_Function - | Name_Volatile_Function + elsif + Pragma_Significant_To_Subprograms + (Get_Pragma_Id (Decl)) then Remove (Decl); Insert_After (Insert_Nod, Decl); @@ -4223,7 +4219,6 @@ package body Sem_Ch6 is Analyze_Generic_Subprogram_Body (N, Spec_Id); if Nkind (N) = N_Subprogram_Body then - HSS := Handled_Statement_Sequence (N); Check_Missing_Return; end if; @@ -5157,9 +5152,27 @@ package body Sem_Ch6 is end; end if; - -- Now we can go on to analyze the body + -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context + -- may now appear in parameter and result profiles. Since the analysis + -- of a subprogram body may use the parameter and result profile of the + -- spec, swap any limited views with their non-limited counterpart. + + if Ada_Version >= Ada_2012 and then Present (Spec_Id) then + Exch_Views := Exchange_Limited_Views (Spec_Id); + end if; + + -- Analyze any aspect specifications that appear on the subprogram body + + if Has_Aspects (N) then + Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); + end if; + + -- Process the contract of the subprogram body after analyzing all the + -- contract-related pragmas within the declarations. + + Analyze_Pragmas_In_Declarations (Body_Id); + Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id); - HSS := Handled_Statement_Sequence (N); Set_Actual_Subtypes (N, Current_Scope); -- Add a declaration for the Protection object, renaming declarations @@ -5180,15 +5193,6 @@ package body Sem_Ch6 is (Sloc (N), Spec_Id, Prot_Typ, N, Declarations (N)); end if; - -- Ada 2012 (AI05-0151): Incomplete types coming from a limited context - -- may now appear in parameter and result profiles. Since the analysis - -- of a subprogram body may use the parameter and result profile of the - -- spec, swap any limited views with their non-limited counterpart. - - if Ada_Version >= Ada_2012 and then Present (Spec_Id) then - Exch_Views := Exchange_Limited_Views (Spec_Id); - end if; - -- If the return type is an anonymous access type whose designated type -- is the limited view of a class-wide type and the non-limited view is -- available, update the return type accordingly. @@ -5225,12 +5229,6 @@ package body Sem_Ch6 is end; end if; - -- Analyze any aspect specifications that appear on the subprogram body - - if Has_Aspects (N) then - Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); - end if; - Analyze_Declarations (Declarations (N)); -- Verify that the SPARK_Mode of the body agrees with that of its spec @@ -5269,17 +5267,11 @@ package body Sem_Ch6 is end if; end if; - -- A subprogram body freezes its own contract. Analyze the contract - -- after the declarations of the body have been processed as pragmas - -- are now chained on the contract of the subprogram body. - - Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id); - -- Check completion, and analyze the statements Check_Completion; Inspect_Deferred_Constant_Completion (Declarations (N)); - Analyze (HSS); + Analyze (Handled_Statement_Sequence (N)); -- Add the generated minimum accessibility objects to the subprogram -- body's list of declarations after analysis of the statements and @@ -5296,7 +5288,8 @@ package body Sem_Ch6 is -- Deal with end of scope processing for the body - Process_End_Label (HSS, 't', Current_Scope); + Process_End_Label + (Handled_Statement_Sequence (N), 't', Current_Scope); Update_Use_Clause_Chain; End_Scope; @@ -5409,17 +5402,9 @@ package body Sem_Ch6 is -- we have a special test to set X as apparently assigned to suppress -- the warning. - -- If X above is controlled, we need to use First_Real_Statement to skip - -- generated finalization-related code. Otherwise (First_Real_Statement - -- is Empty), we just get the first statement. - declare - Stm : Node_Id := First_Real_Statement (HSS); + Stm : Node_Id := First (Statements (Handled_Statement_Sequence (N))); begin - if No (Stm) then - Stm := First (Statements (HSS)); - end if; - -- Skip call markers installed by the ABE mechanism, labels, and -- Push_xxx_Error_Label to find the first real statement. @@ -5519,12 +5504,22 @@ package body Sem_Ch6 is -- Check references of the subprogram spec when we are dealing with -- an expression function due to it having a generated body. - -- Otherwise, we simply check the formals of the subprogram body. if Present (Spec_Id) and then Is_Expression_Function (Spec_Id) then Check_References (Spec_Id); + + -- Skip the check for subprograms generated for protected subprograms + -- because it is also done for the protected subprograms themselves. + + elsif Present (Spec_Id) + and then Present (Protected_Subprogram (Spec_Id)) + then + null; + + -- Otherwise, we simply check the formals of the subprogram body. + else Check_References (Body_Id); end if; diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 2f8f01b..cae0f23 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -27,7 +27,6 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Contracts; use Contracts; -with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -65,6 +64,7 @@ with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Style; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -140,14 +140,6 @@ package body Sem_Ch9 is pragma Assert (Nkind (N) in N_Protected_Type_Declaration | N_Protected_Body); - -- The lock-free implementation is currently enabled through a debug - -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the - -- lock-free implementation. In that case, the debug flag is not needed. - - if not Lock_Free_Given and then not Debug_Flag_9 then - return False; - end if; - -- Get the number of errors detected by the compiler so far if Lock_Free_Given then @@ -215,6 +207,27 @@ package body Sem_Ch9 is Next (Par); end loop; end; + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then + Nkind (Specification (Decl)) = N_Function_Specification + and then + Nkind (Result_Definition (Specification (Decl))) + in N_Has_Entity + and then + Needs_Secondary_Stack + (Entity (Result_Definition (Specification (Decl)))) + then + if Lock_Free_Given then + -- Message text is imprecise; "unconstrained" is + -- similar to "needs secondary stack" but not identical. + Error_Msg_N + ("unconstrained function result subtype not allowed " + & "when Lock_Free given", + Decl); + else + return False; + end if; end if; -- Examine private declarations after visible declarations @@ -254,11 +267,6 @@ package body Sem_Ch9 is function Satisfies_Lock_Free_Requirements (Sub_Body : Node_Id) return Boolean is - Is_Procedure : constant Boolean := - Ekind (Corresponding_Spec (Sub_Body)) = - E_Procedure; - -- Indicates if Sub_Body is a procedure body - Comp : Entity_Id := Empty; -- Track the current component which the body references @@ -338,222 +346,220 @@ package body Sem_Ch9 is -- Start of processing for Check_Node begin - if Is_Procedure then - -- Allocators restricted - - if Kind = N_Allocator then - if Lock_Free_Given then - Error_Msg_N ("allocator not allowed", N); - return Skip; - end if; + -- Allocators restricted - return Abandon; + if Kind = N_Allocator then + if Lock_Free_Given then + Error_Msg_N ("allocator not allowed", N); + return Skip; + end if; - -- Aspects Address, Export and Import restricted + return Abandon; - elsif Kind = N_Aspect_Specification then - declare - Asp_Name : constant Name_Id := - Chars (Identifier (N)); - Asp_Id : constant Aspect_Id := - Get_Aspect_Id (Asp_Name); + -- Aspects Address, Export and Import restricted - begin - if Asp_Id = Aspect_Address or else - Asp_Id = Aspect_Export or else - Asp_Id = Aspect_Import - then - Error_Msg_Name_1 := Asp_Name; + elsif Kind = N_Aspect_Specification then + declare + Asp_Name : constant Name_Id := + Chars (Identifier (N)); + Asp_Id : constant Aspect_Id := + Get_Aspect_Id (Asp_Name); - if Lock_Free_Given then - Error_Msg_N ("aspect% not allowed", N); - return Skip; - end if; + begin + if Asp_Id = Aspect_Address or else + Asp_Id = Aspect_Export or else + Asp_Id = Aspect_Import + then + Error_Msg_Name_1 := Asp_Name; - return Abandon; + if Lock_Free_Given then + Error_Msg_N ("aspect% not allowed", N); + return Skip; end if; - end; - -- Address attribute definition clause restricted + return Abandon; + end if; + end; - elsif Kind = N_Attribute_Definition_Clause - and then Get_Attribute_Id (Chars (N)) = - Attribute_Address - then - Error_Msg_Name_1 := Chars (N); + -- Address attribute definition clause restricted - if Lock_Free_Given then - if From_Aspect_Specification (N) then - Error_Msg_N ("aspect% not allowed", N); - else - Error_Msg_N ("% clause not allowed", N); - end if; + elsif Kind = N_Attribute_Definition_Clause + and then Get_Attribute_Id (Chars (N)) = + Attribute_Address + then + Error_Msg_Name_1 := Chars (N); - return Skip; + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("% clause not allowed", N); end if; - return Abandon; + return Skip; + end if; - -- Non-static Attribute references that don't denote a - -- static function restricted. + return Abandon; - elsif Kind = N_Attribute_Reference - and then not Is_OK_Static_Expression (N) - and then not Is_Static_Function (N) - then - if Lock_Free_Given then - Error_Msg_N - ("non-static attribute reference not allowed", N); - return Skip; - end if; + -- Non-static Attribute references that don't denote a + -- static function restricted. - return Abandon; + elsif Kind = N_Attribute_Reference + and then not Is_OK_Static_Expression (N) + and then not Is_Static_Function (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static attribute reference not allowed", N); + return Skip; + end if; - -- Delay statements restricted + return Abandon; - elsif Kind in N_Delay_Statement then - if Lock_Free_Given then - Error_Msg_N ("delay not allowed", N); - return Skip; - end if; + -- Delay statements restricted - return Abandon; + elsif Kind in N_Delay_Statement then + if Lock_Free_Given then + Error_Msg_N ("delay not allowed", N); + return Skip; + end if; - -- Dereferences of access values restricted + return Abandon; - elsif Kind = N_Explicit_Dereference - or else (Kind = N_Selected_Component - and then Is_Access_Type (Etype (Prefix (N)))) - then - if Lock_Free_Given then - Error_Msg_N - ("dereference of access value not allowed", N); - return Skip; - end if; + -- Dereferences of access values restricted - return Abandon; + elsif Kind = N_Explicit_Dereference + or else (Kind = N_Selected_Component + and then Is_Access_Type (Etype (Prefix (N)))) + then + if Lock_Free_Given then + Error_Msg_N + ("dereference of access value not allowed", N); + return Skip; + end if; - -- Non-static function calls restricted + return Abandon; - elsif Kind = N_Function_Call - and then not Is_OK_Static_Expression (N) - then - if Lock_Free_Given then - Error_Msg_N - ("non-static function call not allowed", N); - return Skip; - end if; + -- Non-static function calls restricted - return Abandon; + elsif Kind = N_Function_Call + and then not Is_OK_Static_Expression (N) + then + if Lock_Free_Given then + Error_Msg_N + ("non-static function call not allowed", N); + return Skip; + end if; - -- Goto statements restricted + return Abandon; - elsif Kind = N_Goto_Statement then - if Lock_Free_Given then - Error_Msg_N ("goto statement not allowed", N); - return Skip; - end if; + -- Goto statements restricted - return Abandon; + elsif Kind = N_Goto_Statement then + if Lock_Free_Given then + Error_Msg_N ("goto statement not allowed", N); + return Skip; + end if; - -- References + return Abandon; - elsif Kind = N_Identifier - and then Present (Entity (N)) - then - declare - Id : constant Entity_Id := Entity (N); - Sub_Id : constant Entity_Id := - Corresponding_Spec (Sub_Body); + -- References - begin - -- Prohibit references to non-constant entities - -- outside the protected subprogram scope. - - if Ekind (Id) in Assignable_Kind - and then not - Scope_Within_Or_Same (Scope (Id), Sub_Id) - and then not - Scope_Within_Or_Same - (Scope (Id), - Protected_Body_Subprogram (Sub_Id)) - then - if Lock_Free_Given then - Error_Msg_NE - ("reference to global variable& not " & - "allowed", N, Id); - return Skip; - end if; + elsif Kind = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Sub_Id : constant Entity_Id := + Corresponding_Spec (Sub_Body); - return Abandon; + begin + -- Prohibit references to non-constant entities + -- outside the protected subprogram scope. + + if Ekind (Id) in Assignable_Kind + and then not + Scope_Within_Or_Same (Scope (Id), Sub_Id) + and then not + Scope_Within_Or_Same + (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + if Lock_Free_Given then + Error_Msg_NE + ("reference to global variable& not " & + "allowed", N, Id); + return Skip; end if; - end; - - -- Loop statements restricted - elsif Kind = N_Loop_Statement then - if Lock_Free_Given then - Error_Msg_N ("loop not allowed", N); - return Skip; + return Abandon; end if; + end; - return Abandon; + -- Loop statements restricted - -- Pragmas Export and Import restricted + elsif Kind = N_Loop_Statement then + if Lock_Free_Given then + Error_Msg_N ("loop not allowed", N); + return Skip; + end if; - elsif Kind = N_Pragma then - declare - Prag_Name : constant Name_Id := - Pragma_Name (N); - Prag_Id : constant Pragma_Id := - Get_Pragma_Id (Prag_Name); + return Abandon; - begin - if Prag_Id = Pragma_Export - or else Prag_Id = Pragma_Import - then - Error_Msg_Name_1 := Prag_Name; + -- Pragmas Export and Import restricted - if Lock_Free_Given then - if From_Aspect_Specification (N) then - Error_Msg_N ("aspect% not allowed", N); - else - Error_Msg_N ("pragma% not allowed", N); - end if; + elsif Kind = N_Pragma then + declare + Prag_Name : constant Name_Id := + Pragma_Name (N); + Prag_Id : constant Pragma_Id := + Get_Pragma_Id (Prag_Name); + + begin + if Prag_Id = Pragma_Export + or else Prag_Id = Pragma_Import + then + Error_Msg_Name_1 := Prag_Name; - return Skip; + if Lock_Free_Given then + if From_Aspect_Specification (N) then + Error_Msg_N ("aspect% not allowed", N); + else + Error_Msg_N ("pragma% not allowed", N); end if; - return Abandon; + return Skip; end if; - end; - -- Procedure call statements restricted - - elsif Kind = N_Procedure_Call_Statement then - if Lock_Free_Given then - Error_Msg_N ("procedure call not allowed", N); - return Skip; + return Abandon; end if; + end; - return Abandon; + -- Procedure call statements restricted - -- Quantified expression restricted. Note that we have - -- to check the original node as well, since at this - -- stage, it may have been rewritten. + elsif Kind = N_Procedure_Call_Statement then + if Lock_Free_Given then + Error_Msg_N ("procedure call not allowed", N); + return Skip; + end if; - elsif Kind = N_Quantified_Expression - or else - Nkind (Original_Node (N)) = N_Quantified_Expression - then - if Lock_Free_Given then - Error_Msg_N - ("quantified expression not allowed", N); - return Skip; - end if; + return Abandon; - return Abandon; + -- Quantified expression restricted. Note that we have + -- to check the original node as well, since at this + -- stage, it may have been rewritten. + + elsif Kind = N_Quantified_Expression + or else + Nkind (Original_Node (N)) = N_Quantified_Expression + then + if Lock_Free_Given then + Error_Msg_N + ("quantified expression not allowed", N); + return Skip; end if; + + return Abandon; end if; -- A protected subprogram (function or procedure) may @@ -644,6 +650,35 @@ package body Sem_Ch9 is -- Start of processing for Satisfies_Lock_Free_Requirements begin + if not Support_Atomic_Primitives_On_Target then + if Lock_Free_Given then + Error_Msg_N + ("Lock_Free aspect requires target support for " + & "atomic primitives", N); + end if; + return False; + end if; + + -- Deal with case where Ceiling_Locking locking policy is + -- in effect. + + if Locking_Policy = 'C' then + if Lock_Free_Given then + -- Explicit Lock_Free aspect spec overrides + -- Ceiling_Locking so we generate a warning. + + Error_Msg_N + ("Lock_Free aspect specification overrides " + & "Ceiling_Locking locking policy??", N); + else + -- If Ceiling_Locking locking policy is in effect, then + -- Lock_Free can be explicitly specified but it is + -- never the default. + + return False; + end if; + end if; + -- Get the number of errors detected by the compiler so far if Lock_Free_Given then diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index b8e3fb6..f912f8b 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1809,11 +1809,6 @@ package body Sem_Elab is -- Determine whether arbitrary entity Id denotes a partial invariant -- procedure. - function Is_Postconditions_Proc (Id : Entity_Id) return Boolean; - pragma Inline (Is_Postconditions_Proc); - -- Determine whether arbitrary entity Id denotes internally generated - -- routine _Postconditions. - function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean; pragma Inline (Is_Preelaborated_Unit); -- Determine whether arbitrary entity Id denotes a unit which is subject @@ -2481,14 +2476,6 @@ package body Sem_Elab is elsif Is_Partial_Invariant_Proc (Subp_Id) then null; - -- _Postconditions - - elsif Is_Postconditions_Proc (Subp_Id) then - Output_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "subprogram"); - -- Subprograms must come last because some of the previous cases fall -- under this category. @@ -6638,14 +6625,6 @@ package body Sem_Elab is elsif Is_Partial_Invariant_Proc (Subp_Id) then null; - -- _Postconditions - - elsif Is_Postconditions_Proc (Subp_Id) then - Info_Verification_Call - (Pred => "postconditions", - Id => Find_Enclosing_Scope (Call), - Id_Kind => "subprogram"); - -- Subprograms must come last because some of the previous cases -- fall under this category. @@ -13091,10 +13070,6 @@ package body Sem_Elab is (Extra : out Entity_Id; Kind : out Invocation_Kind) is - Targ_Rep : constant Target_Rep_Id := - Target_Representation_Of (Targ_Id, In_State); - Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep); - begin -- Accept within a task body @@ -13180,12 +13155,6 @@ package body Sem_Elab is Extra := First_Formal_Type (Targ_Id); Kind := Invariant_Verification; - -- Postcondition verification - - elsif Is_Postconditions_Proc (Targ_Id) then - Extra := Find_Enclosing_Scope (Spec_Decl); - Kind := Postcondition_Verification; - -- Protected entry call elsif Is_Protected_Entry (Targ_Id) then @@ -14454,8 +14423,7 @@ package body Sem_Elab is Is_Default_Initial_Condition_Proc (Id) or else Is_Initial_Condition_Proc (Id) or else Is_Invariant_Proc (Id) - or else Is_Partial_Invariant_Proc (Id) - or else Is_Postconditions_Proc (Id); + or else Is_Partial_Invariant_Proc (Id); end Is_Assertion_Pragma_Target; ---------------------------- @@ -14497,7 +14465,6 @@ package body Sem_Elab is Is_Accept_Alternative_Proc (Id) or else Is_Finalizer_Proc (Id) or else Is_Partial_Invariant_Proc (Id) - or else Is_Postconditions_Proc (Id) or else Is_TSS (Id, TSS_Deep_Adjust) or else Is_TSS (Id, TSS_Deep_Finalize) or else Is_TSS (Id, TSS_Deep_Initialize); @@ -14653,18 +14620,6 @@ package body Sem_Elab is and then Is_Partial_Invariant_Procedure (Id); end Is_Partial_Invariant_Proc; - ---------------------------- - -- Is_Postconditions_Proc -- - ---------------------------- - - function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is - begin - -- To qualify, the entity must denote a _Postconditions procedure - - return - Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions; - end Is_Postconditions_Proc; - --------------------------- -- Is_Preelaborated_Unit -- --------------------------- @@ -17482,7 +17437,7 @@ package body Sem_Elab is if Nkind (N) = N_Procedure_Call_Statement and then Is_Entity_Name (Name (N)) - and then Chars (Entity (Name (N))) = Name_uPostconditions + and then Chars (Entity (Name (N))) = Name_uWrapped_Statements then return; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index df3d348..77ff68e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5548,6 +5548,14 @@ package body Sem_Prag is then OK := True; + -- Special case for postconditions wrappers + + elsif Ekind (Scop) in Subprogram_Kind + and then Present (Wrapped_Statements (Scop)) + and then Wrapped_Statements (Scop) = Current_Scope + then + OK := True; + -- Default case, just check that the pragma occurs in the scope -- of the entity denoted by the name. @@ -9430,8 +9438,8 @@ package body Sem_Prag is -- If the pragma comes from an aspect specification, there -- must be an Import aspect specified as well. In the rare - -- case where Import is set to False, the suprogram needs to - -- have a local completion. + -- case where Import is set to False, the subprogram needs + -- to have a local completion. declare Imp_Aspect : constant Node_Id := @@ -20139,7 +20147,7 @@ package body Sem_Prag is end loop; -- If entity in not in current scope it may be the enclosing - -- suprogram body to which the aspect applies. + -- subprogram body to which the aspect applies. if not Found then if Entity (Id) = Current_Scope @@ -23168,7 +23176,7 @@ package body Sem_Prag is -- SPARK_Mode -- ---------------- - -- pragma SPARK_Mode [(On | Off)]; + -- pragma SPARK_Mode [(Auto | On | Off)]; when Pragma_SPARK_Mode => Do_SPARK_Mode : declare Mode_Id : SPARK_Mode_Type; @@ -23654,7 +23662,7 @@ package body Sem_Prag is -- Check the legality of the mode (no argument = ON) if Arg_Count = 1 then - Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + Check_Arg_Is_One_Of (Arg1, Name_Auto, Name_On, Name_Off); Mode := Chars (Get_Pragma_Arg (Arg1)); else Mode := Name_On; @@ -23705,6 +23713,15 @@ package body Sem_Prag is -- the pragma resides to find a potential construct. else + -- An explicit mode of Auto is only allowed as a configuration + -- pragma. Escape "pragma" to avoid replacement with "aspect". + + if Mode_Id = None then + Error_Pragma_Arg + ("only configuration 'p'r'a'g'm'a% can have value &", + Arg1); + end if; + Stmt := Prev (N); while Present (Stmt) loop @@ -26138,12 +26155,9 @@ package body Sem_Prag is if Class_Present (N) then -- Verify that a class-wide condition is legal, i.e. the operation is - -- a primitive of a tagged type. Note that a generic subprogram is - -- not a primitive operation. - - Disp_Typ := Find_Dispatching_Type (Spec_Id); + -- a primitive of a tagged type. - if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then + if not Is_Dispatching_Operation (Spec_Id) then Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N); if From_Aspect_Specification (N) then @@ -26162,6 +26176,7 @@ package body Sem_Prag is -- Remaining semantic checks require a full tree traversal else + Disp_Typ := Find_Dispatching_Type (Spec_Id); Check_Class_Wide_Condition (Expr); end if; @@ -31157,23 +31172,26 @@ package body Sem_Prag is end if; end Get_Base_Subprogram; - ----------------------- + ------------------------- -- Get_SPARK_Mode_Type -- - ----------------------- + ------------------------- function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is begin - if N = Name_On then - return On; - elsif N = Name_Off then - return Off; + case N is + when Name_Auto => + return None; + when Name_On => + return On; + when Name_Off => + return Off; - -- Any other argument is illegal. Assume that no SPARK mode applies to - -- avoid potential cascaded errors. + -- Any other argument is illegal. Assume that no SPARK mode applies + -- to avoid potential cascaded errors. - else - return None; - end if; + when others => + return None; + end case; end Get_SPARK_Mode_Type; ------------------------------------ @@ -32238,10 +32256,10 @@ package body Sem_Prag is then return; - -- Do not process internally generated routine _Postconditions + -- Do not process internally generated routine _Wrapped_Statements elsif Ekind (Body_Id) = E_Procedure - and then Chars (Body_Id) = Name_uPostconditions + and then Chars (Body_Id) = Name_uWrapped_Statements then return; end if; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index e8a65ce..619f841 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -156,6 +156,9 @@ package Sem_Prag is Pragma_Type_Invariant_Class => True, others => False); + -- Should to following constant arrays be renamed to better suit their + -- use as a predicate (e.g. Is_Pragma_*) ??? + -- The following table lists all the implementation-defined pragmas that -- should apply to the anonymous object produced by the analysis of a -- single protected or task type. The table should be synchronized with @@ -200,6 +203,32 @@ package Sem_Prag is Pragma_Warnings => False, others => True); + -- The following table lists all pragmas which are relevant to the analysis + -- of subprogram bodies. + + Pragma_Significant_To_Subprograms : constant array (Pragma_Id) of Boolean := + (Pragma_Contract_Cases => True, + Pragma_Depends => True, + Pragma_Ghost => True, + Pragma_Global => True, + Pragma_Inline => True, + Pragma_Inline_Always => True, + Pragma_Post => True, + Pragma_Post_Class => True, + Pragma_Postcondition => True, + Pragma_Pre => True, + Pragma_Pre_Class => True, + Pragma_Precondition => True, + Pragma_Pure => True, + Pragma_Pure_Function => True, + Pragma_Refined_Depends => True, + Pragma_Refined_Global => True, + Pragma_Refined_Post => True, + Pragma_Refined_State => True, + Pragma_Volatile => True, + Pragma_Volatile_Function => True, + others => False); + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f618467..7675070 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8412,6 +8412,7 @@ package body Sem_Res is if Is_Entry (Nam) and then Present (Contract_Wrapper (Nam)) and then Current_Scope /= Contract_Wrapper (Nam) + and then Current_Scope /= Wrapped_Statements (Contract_Wrapper (Nam)) then -- Note the entity being called before rewriting the call, so that -- it appears used at this point. @@ -8876,6 +8877,20 @@ package body Sem_Res is end if; else + + -- For Ada 2022, check for user-defined literals when the type has + -- the appropriate aspect. + + if Has_Applicable_User_Defined_Literal (L, Etype (R)) then + Resolve (L, Etype (R)); + Set_Etype (N, Standard_Boolean); + end if; + + if Has_Applicable_User_Defined_Literal (R, Etype (L)) then + Resolve (R, Etype (L)); + Set_Etype (N, Standard_Boolean); + end if; + -- Deal with other error cases if T = Any_String or else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ecfb49a..b0babeb 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -316,8 +316,20 @@ package body Sem_Util is -- Ignore transient scopes made during expansion if Comes_From_Source (Node_Par) then - return - Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; + -- Note that in some rare cases the scope depth may not be + -- set, for example, when we are in the middle of analyzing + -- a type and the enclosing scope is said type. So, instead, + -- continue to move up the parent chain since the scope + -- depth of the type's parent is the same as that of the + -- type. + + if not Scope_Depth_Set (Encl_Scop) then + pragma Assert (Nkind (Parent (Encl_Scop)) + = N_Full_Type_Declaration); + else + return + Scope_Depth (Encl_Scop) + Master_Lvl_Modifier; + end if; end if; -- For a return statement within a function, return @@ -597,6 +609,7 @@ package body Sem_Util is -- Anonymous access types elsif Nkind (Pre) in N_Has_Entity + and then Ekind (Entity (Pre)) not in Subprogram_Kind and then Present (Get_Dynamic_Accessibility (Entity (Pre))) and then Level = Dynamic_Level then @@ -6691,8 +6704,6 @@ package body Sem_Util is Wmsg : Boolean; Eloc : Source_Ptr; - -- Start of processing for Compile_Time_Constraint_Error - begin -- If this is a warning, convert it into an error if we are in code -- subject to SPARK_Mode being set On, unless Warn is True to force a @@ -7184,7 +7195,51 @@ package body Sem_Util is Typ : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op); Elmt : Elmt_Id; Subp : Entity_Id; - Prim : Entity_Id; + + function Profile_Matches_Ancestor (S : Entity_Id) return Boolean; + -- Returns True if subprogram S has the proper profile for an + -- overriding of Ancestor_Op (that is, corresponding formals either + -- have the same type, or are corresponding controlling formals, + -- and similarly for result types). + + ------------------------------ + -- Profile_Matches_Ancestor -- + ------------------------------ + + function Profile_Matches_Ancestor (S : Entity_Id) return Boolean is + F1 : Entity_Id := First_Formal (Ancestor_Op); + F2 : Entity_Id := First_Formal (S); + + begin + if Ekind (Ancestor_Op) /= Ekind (S) then + return False; + end if; + + -- ??? This should probably account for anonymous access formals, + -- but the parent function (Corresponding_Primitive_Op) is currently + -- only called for user-defined literal functions, which can't have + -- such formals. But if this is ever used in a more general context + -- it should be extended to handle such formals (and result types). + + while Present (F1) and then Present (F2) loop + if Etype (F1) = Etype (F2) + or else Is_Ancestor (Typ, Etype (F2)) + then + Next_Formal (F1); + Next_Formal (F2); + else + return False; + end if; + end loop; + + return No (F1) + and then No (F2) + and then (Etype (Ancestor_Op) = Etype (S) + or else Is_Ancestor (Typ, Etype (S))); + end Profile_Matches_Ancestor; + + -- Start of processing for Corresponding_Primitive_Op + begin pragma Assert (Is_Dispatching_Operation (Ancestor_Op)); pragma Assert (Is_Ancestor (Typ, Descendant_Type) @@ -7195,12 +7250,12 @@ package body Sem_Util is while Present (Elmt) loop Subp := Node (Elmt); - -- For regular primitives we only need to traverse the chain of - -- ancestors when the name matches the name of Ancestor_Op, but - -- for predefined dispatching operations we cannot rely on the - -- name of the primitive to identify a candidate since their name - -- is internally built adding a suffix to the name of the tagged - -- type. + -- For regular primitives we need to check the profile against + -- the ancestor when the name matches the name of Ancestor_Op, + -- but for predefined dispatching operations we cannot rely on + -- the name of the primitive to identify a candidate since their + -- name is internally built by adding a suffix to the name of the + -- tagged type. if Chars (Subp) = Chars (Ancestor_Op) or else Is_Predefined_Dispatching_Operation (Subp) @@ -7216,26 +7271,10 @@ package body Sem_Util is return Alias (Subp); end if; - -- Traverse the chain of ancestors searching for Ancestor_Op. - -- Overridden primitives have attribute Overridden_Operation; - -- inherited primitives have attribute Alias. - - else - Prim := Subp; - - while Present (Overridden_Operation (Prim)) - or else Present (Alias (Prim)) - loop - if Present (Overridden_Operation (Prim)) then - Prim := Overridden_Operation (Prim); - else - Prim := Alias (Prim); - end if; + -- Otherwise, return subprogram when profile matches its ancestor - if Prim = Ancestor_Op then - return Subp; - end if; - end loop; + elsif Profile_Matches_Ancestor (Subp) then + return Subp; end if; end if; @@ -10894,7 +10933,7 @@ package body Sem_Util is -- First. Assoc := First (Component_Associations (Expression (Aspect))); - First_Op := Any_Id; + First_Op := Any_Id; while Present (Assoc) loop if Chars (First (Choices (Assoc))) = Name_First then First_Op := Expression (Assoc); @@ -14096,9 +14135,10 @@ package body Sem_Util is if Subp_Nam = Name_uFinalizer then return False; - -- _Postconditions procedure + -- _Wrapped_Statements procedure which gets generated as part of the + -- expansion of postconditions. - elsif Subp_Nam = Name_uPostconditions then + elsif Subp_Nam = Name_uWrapped_Statements then return False; -- Predicate function @@ -21622,8 +21662,22 @@ package body Sem_Util is N_String_Literal => Aspect_String_Literal); begin - return Nkind (N) in N_Numeric_Or_String_Literal - and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))); + -- Return True when N is either a literal or a named number and the + -- type has the appropriate user-defined literal aspect. + + return (Nkind (N) in N_Numeric_Or_String_Literal + and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))))) + or else + (Is_Entity_Name (N) + and then Present (Entity (N)) + and then + ((Ekind (Entity (N)) = E_Named_Integer + and then + Present (Find_Aspect (Typ, Aspect_Integer_Literal))) + or else + (Ekind (Entity (N)) = E_Named_Real + and then + Present (Find_Aspect (Typ, Aspect_Real_Literal))))); end Is_User_Defined_Literal; -------------------------------------- @@ -22900,6 +22954,7 @@ package body Sem_Util is | N_Function_Call | N_Raise_Statement | N_Raise_xxx_Error + | N_Raise_Expression then Result := True; return Abandon; @@ -24049,13 +24104,6 @@ package body Sem_Util is pragma Inline (Update_CFS_Sloc); -- Update the Comes_From_Source and Sloc attributes of node or entity N - procedure Update_First_Real_Statement - (Old_HSS : Node_Id; - New_HSS : Node_Id); - pragma Inline (Update_First_Real_Statement); - -- Update semantic attribute First_Real_Statement of handled sequence of - -- statements New_HSS based on handled sequence of statements Old_HSS. - procedure Update_Named_Associations (Old_Call : Node_Id; New_Call : Node_Id); @@ -24570,14 +24618,6 @@ package body Sem_Util is Set_Renamed_Object_Of_Possibly_Void (Defining_Entity (Result), Name (Result)); - -- Update the First_Real_Statement attribute of a replicated - -- handled sequence of statements. - - elsif Nkind (N) = N_Handled_Sequence_Of_Statements then - Update_First_Real_Statement - (Old_HSS => N, - New_HSS => Result); - -- Update the Chars attribute of identifiers elsif Nkind (N) = N_Identifier then @@ -24680,39 +24720,6 @@ package body Sem_Util is end if; end Update_CFS_Sloc; - --------------------------------- - -- Update_First_Real_Statement -- - --------------------------------- - - procedure Update_First_Real_Statement - (Old_HSS : Node_Id; - New_HSS : Node_Id) - is - Old_First_Stmt : constant Node_Id := First_Real_Statement (Old_HSS); - - New_Stmt : Node_Id; - Old_Stmt : Node_Id; - - begin - -- Recreate the First_Real_Statement attribute of a handled sequence - -- of statements by traversing the statement lists of both sequences - -- in parallel. - - if Present (Old_First_Stmt) then - New_Stmt := First (Statements (New_HSS)); - Old_Stmt := First (Statements (Old_HSS)); - while Present (Old_Stmt) and then Old_Stmt /= Old_First_Stmt loop - Next (New_Stmt); - Next (Old_Stmt); - end loop; - - pragma Assert (Present (New_Stmt)); - pragma Assert (Present (Old_Stmt)); - - Set_First_Real_Statement (New_HSS, New_Stmt); - end if; - end Update_First_Real_Statement; - ------------------------------- -- Update_Named_Associations -- ------------------------------- @@ -25424,8 +25431,8 @@ package body Sem_Util is -- * Semantic fields of entities such as Etype and Scope must be -- updated to reference the proper replicated entities. - -- * Semantic fields of nodes such as First_Real_Statement must be - -- updated to reference the proper replicated nodes. + -- * Some semantic fields of nodes must be updated to reference + -- the proper replicated nodes. -- Finally, quantified expressions contain an implicit declaration for -- the bound variable. Given that quantified expressions appearing @@ -28020,8 +28027,18 @@ package body Sem_Util is E : Entity_Id) return Boolean is Subp_Alias : constant Entity_Id := Alias (S); + Subp : Entity_Id := E; begin - return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); + -- During expansion of subprograms with postconditions the original + -- subprogram's declarations and statements get wrapped into a local + -- _Wrapped_Statements subprogram. + + if Chars (Subp) = Name_uWrapped_Statements then + Subp := Enclosing_Subprogram (Subp); + end if; + + return S = Subp + or else (Present (Subp_Alias) and then Subp_Alias = Subp); end Same_Or_Aliased_Subprograms; --------------- @@ -32469,7 +32486,7 @@ package body Sem_Util is and then Ekind (Scope (T)) in E_Entry | E_Entry_Family | E_Function | E_Procedure and then - (Present (Postconditions_Proc (Scope (T))) + (Present (Wrapped_Statements (Scope (T))) or else Present (Contract (Scope (T)))) then -- ??? Should define a flag for this. We could incorrectly diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9f909e0..132c2b8 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2500,7 +2500,9 @@ package Sem_Util is (N : Node_Id; Typ : Entity_Id) return Boolean; pragma Inline (Is_User_Defined_Literal); - -- Determine whether N is a user-defined literal for Typ + -- Determine whether N is a user-defined literal for Typ, including + -- the case where N denotes a named number of the appropriate kind + -- when Typ has an Integer_Literal or Real_Literal aspect. function Is_Validation_Variable_Reference (N : Node_Id) return Boolean; -- Determine whether N denotes a reference to a variable which captures the @@ -2743,7 +2745,6 @@ package Sem_Util is -- fields are recreated after the replication takes place. -- -- First_Named_Actual - -- First_Real_Statement -- Next_Named_Actual -- -- If applicable, the Etype field (if any) is updated to refer to a diff --git a/gcc/ada/sinfo-utils.ads b/gcc/ada/sinfo-utils.ads index 78b2d0e..3f25034 100644 --- a/gcc/ada/sinfo-utils.ads +++ b/gcc/ada/sinfo-utils.ads @@ -54,6 +54,12 @@ package Sinfo.Utils is -- Miscellaneous Tree Access Subprograms -- ------------------------------------------- + function First_Real_Statement -- ???? + (Ignored : N_Handled_Sequence_Of_Statements_Id) return Node_Id is (Empty); + -- The First_Real_Statement field is going away, but it is referenced in + -- codepeer and gnat-llvm. This is a temporary version, always returning + -- Empty, to ease the transition. + function End_Location (N : Node_Id) return Source_Ptr; -- N is an N_If_Statement or N_Case_Statement node, and this function -- returns the location of the IF token in the END IF sequence by diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index fddfc72..53880c5 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -82,6 +82,12 @@ package Sinfo is -- for this purpose, so e.g. in X := (if A then B else C); -- Paren_Count for the right side will be 1. + -- Comes_From_Check_Or_Contract + -- This flag is present in all N_If_Statement nodes and + -- gets set when an N_If_Statement is generated as part of + -- the expansion of a Check, Assert, or contract-related + -- pragma. + -- Comes_From_Source -- This flag is present in all nodes. It is set if the -- node is built by the scanner or parser, and clear if @@ -891,9 +897,12 @@ package Sinfo is -- required for the corresponding reference or modification. -- At_End_Proc - -- This field is present in an N_Handled_Sequence_Of_Statements node. + -- This field is present in N_Handled_Sequence_Of_Statements, + -- N_Package_Body, N_Subprogram_Body, N_Task_Body, N_Block_Statement, + -- and N_Entry_Body. -- It contains an identifier reference for the cleanup procedure to be - -- called. See description of this node for further details. + -- called. See description of N_Handled_Sequence_Of_Statements node + -- for further details. -- Backwards_OK -- A flag present in the N_Assignment_Statement node. It is used only @@ -1307,15 +1316,6 @@ package Sinfo is -- named associations). Note: this field points to the explicit actual -- parameter itself, not the N_Parameter_Association node (its parent). - -- First_Real_Statement - -- Present in N_Handled_Sequence_Of_Statements node. Normally set to - -- Empty. Used only when declarations are moved into the statement part - -- of a construct as a result of wrapping an AT END handler that is - -- required to cover the declarations. In this case, this field is used - -- to remember the location in the statements list of the first real - -- statement, i.e. the statement that used to be first in the statement - -- list before the declarations were prepended. - -- First_Subtype_Link -- Present in N_Freeze_Entity node for an anonymous base type that is -- implicitly created by the declaration of a first subtype. It points @@ -5167,6 +5167,7 @@ package Sinfo is -- Is_Finalization_Wrapper -- Is_Initialization_Block -- Is_Task_Master + -- At_End_Proc (set to Empty if no clean up procedure) ------------------------- -- 5.7 Exit Statement -- @@ -5686,6 +5687,7 @@ package Sinfo is -- Handled_Statement_Sequence (set to Empty if no HSS present) -- Corresponding_Spec -- Was_Originally_Stub + -- At_End_Proc (set to Empty if no clean up procedure) -- Note: if a source level package does not contain a handled sequence -- of statements, then the parser supplies a dummy one with a null @@ -6164,6 +6166,7 @@ package Sinfo is -- Declarations -- Handled_Statement_Sequence -- Activation_Chain_Entity + -- At_End_Proc (set to Empty if no clean up procedure) ----------------------------------- -- 9.5.2 Entry Body Formal Part -- @@ -6715,6 +6718,7 @@ package Sinfo is -- Corresponding_Spec_Of_Stub -- Library_Unit points to the subunit -- Corresponding_Body + -- At_End_Proc (set to Empty if no clean up procedure) ------------------------------- -- 10.1.3 Package Body Stub -- @@ -6745,6 +6749,7 @@ package Sinfo is -- Corresponding_Spec_Of_Stub -- Library_Unit points to the subunit -- Corresponding_Body + -- At_End_Proc (set to Empty if no clean up procedure) --------------------------------- -- 10.1.3 Protected Body Stub -- @@ -6830,6 +6835,11 @@ package Sinfo is -- declarations. The big difference is that the cleanup actions occur -- on either a normal or an abnormal exit from the statement sequence. + -- At_End_Proc is also a field of various nodes that can contain + -- both Declarations and Handled_Statement_Sequence, such as subprogram + -- bodies and block statements. In that case, the At_End_Proc + -- protects the Declarations as well as the Handled_Statement_Sequence. + -- Note: the list of Exception_Handlers can contain pragmas as well -- as actual handlers. In practice these pragmas can only occur at -- the start of the list, since any pragmas occurring later on will @@ -6856,7 +6866,6 @@ package Sinfo is -- End_Label (set to Empty if expander generated) -- Exception_Handlers (set to No_List if none present) -- At_End_Proc (set to Empty if no clean up procedure) - -- First_Real_Statement -- Note: A Handled_Sequence_Of_Statements can contain both -- Exception_Handlers and an At_End_Proc. diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index 8701ea9..9b087e6 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -256,8 +256,6 @@ package body Snames is return Pragma_Interface; when Name_Interrupt_Priority => return Pragma_Interrupt_Priority; - when Name_Lock_Free => - return Pragma_Lock_Free; when Name_Preelaborable_Initialization => return Pragma_Preelaborable_Initialization; when Name_Priority => @@ -489,7 +487,6 @@ package body Snames is or else N = Name_Fast_Math or else N = Name_Interface or else N = Name_Interrupt_Priority - or else N = Name_Lock_Free or else N = Name_Preelaborable_Initialization or else N = Name_Priority or else N = Name_Secondary_Stack_Size diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 6a16da1..8f71ad9 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -190,7 +190,6 @@ package Snames is Name_uMaster : constant Name_Id := N + $; Name_uObject : constant Name_Id := N + $; Name_uPost : constant Name_Id := N + $; - Name_uPostconditions : constant Name_Id := N + $; Name_uPostcond_Enabled : constant Name_Id := N + $; Name_uPre : constant Name_Id := N + $; Name_uPriority : constant Name_Id := N + $; @@ -208,6 +207,7 @@ package Snames is Name_uTask_Name : constant Name_Id := N + $; Name_uType_Invariant : constant Name_Id := N + $; Name_uVariants : constant Name_Id := N + $; + Name_uWrapped_Statements : constant Name_Id := N + $; -- Names of predefined primitives used in the expansion of dispatching -- requeue and select statements, Abort, 'Callable and 'Terminated. @@ -600,12 +600,7 @@ package Snames is Name_Linker_Options : constant Name_Id := N + $; Name_Linker_Section : constant Name_Id := N + $; -- GNAT Name_List : constant Name_Id := N + $; - - -- Note: Lock_Free is not in this list because its name matches the name of - -- the corresponding attribute. However, it is included in the definition - -- of the type Pragma_Id and the functions Get_Pragma_Id and Is_Pragma_Name - -- correctly recognize and process Lock_Free. Lock_Free is a GNAT pragma. - + Name_Lock_Free : constant Name_Id := N + $; -- GNAT Name_Loop_Invariant : constant Name_Id := N + $; -- GNAT Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT Name_Loop_Variant : constant Name_Id := N + $; -- GNAT @@ -787,6 +782,7 @@ package Snames is Name_Assertion : constant Name_Id := N + $; Name_Assertions : constant Name_Id := N + $; Name_Attribute_Name : constant Name_Id := N + $; + Name_Auto : constant Name_Id := N + $; Name_Body_File_Name : constant Name_Id := N + $; Name_Boolean_Entry_Barriers : constant Name_Id := N + $; Name_By_Any : constant Name_Id := N + $; @@ -978,7 +974,6 @@ package Snames is Name_Leading_Part : constant Name_Id := N + $; Name_Length : constant Name_Id := N + $; Name_Library_Level : constant Name_Id := N + $; -- GNAT - Name_Lock_Free : constant Name_Id := N + $; -- GNAT Name_Loop_Entry : constant Name_Id := N + $; -- GNAT Name_Machine_Emax : constant Name_Id := N + $; Name_Machine_Emin : constant Name_Id := N + $; @@ -1503,7 +1498,6 @@ package Snames is Attribute_Leading_Part, Attribute_Length, Attribute_Library_Level, - Attribute_Lock_Free, Attribute_Loop_Entry, Attribute_Machine_Emax, Attribute_Machine_Emin, @@ -1889,6 +1883,7 @@ package Snames is Pragma_Linker_Options, Pragma_Linker_Section, Pragma_List, + Pragma_Lock_Free, Pragma_Loop_Invariant, Pragma_Loop_Optimize, Pragma_Loop_Variant, @@ -1981,7 +1976,6 @@ package Snames is Pragma_Fast_Math, Pragma_Interface, Pragma_Interrupt_Priority, - Pragma_Lock_Free, Pragma_Preelaborable_Initialization, Pragma_Priority, Pragma_Secondary_Stack_Size, @@ -2073,10 +2067,10 @@ package Snames is function Is_Pragma_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized pragma. Note -- that pragmas CPU, Dispatching_Domain, Fast_Math, Interrupt_Priority, - -- Lock_Free, Priority, Storage_Size, and Storage_Unit are recognized - -- as pragmas by this function even though their names are separate from - -- the other pragma names. For this reason, clients should always use - -- this function, rather than do range tests on Name_Id values. + -- Priority, Storage_Size, and Storage_Unit are recognized as pragmas by + -- this function even though their names are separate from the other + -- pragma names. For this reason, clients should always use this function, + -- rather than do range tests on Name_Id values. function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized configuration diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 243d67a..0f292c8 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -199,6 +199,9 @@ package body Sprint is -- For the case of Semicolon False, no semicolon is removed or output, and -- all the aspects are printed on a single line. + procedure Sprint_At_End_Proc (Node : Node_Id); + -- Print At_End_Proc attribute if present + procedure Sprint_Bar_List (List : List_Id); -- Print the given list with items separated by vertical bars @@ -750,6 +753,22 @@ package body Sprint is end if; end Sprint_Aspect_Specifications; + ------------------------ + -- Sprint_At_End_Proc -- + ------------------------ + + procedure Sprint_At_End_Proc (Node : Node_Id) is + begin + if Present (At_End_Proc (Node)) then + Write_Indent_Str ("at end"); + Indent_Begin; + Write_Indent; + Sprint_Node (At_End_Proc (Node)); + Write_Char (';'); + Indent_End; + end if; + end Sprint_At_End_Proc; + --------------------- -- Sprint_Bar_List -- --------------------- @@ -1226,6 +1245,7 @@ package body Sprint is end if; Write_Char (';'); + Sprint_At_End_Proc (Node); when N_Call_Marker => null; @@ -1646,6 +1666,7 @@ package body Sprint is Write_Indent_Str ("end "); Write_Id (Defining_Identifier (Node)); Write_Char (';'); + Sprint_At_End_Proc (Node); when N_Entry_Body_Formal_Part => if Present (Entry_Index_Specification (Node)) then @@ -2164,14 +2185,7 @@ package body Sprint is Indent_End; end if; - if Present (At_End_Proc (Node)) then - Write_Indent_Str ("at end"); - Indent_Begin; - Write_Indent; - Sprint_Node (At_End_Proc (Node)); - Write_Char (';'); - Indent_End; - end if; + Sprint_At_End_Proc (Node); when N_Identifier => Set_Debug_Sloc; @@ -2699,6 +2713,7 @@ package body Sprint is Sprint_End_Label (Handled_Statement_Sequence (Node), Defining_Unit_Name (Node)); Write_Char (';'); + Sprint_At_End_Proc (Node); when N_Package_Body_Stub => Write_Indent_Str_Sloc ("package body "); @@ -3326,6 +3341,7 @@ package body Sprint is (Handled_Statement_Sequence (Node), Defining_Unit_Name (Specification (Node))); Write_Char (';'); + Sprint_At_End_Proc (Node); if Is_List_Member (Node) and then Present (Next (Node)) @@ -3398,6 +3414,7 @@ package body Sprint is Sprint_End_Label (Handled_Statement_Sequence (Node), Defining_Identifier (Node)); Write_Char (';'); + Sprint_At_End_Proc (Node); when N_Task_Body_Stub => Write_Indent_Str_Sloc ("task body "); diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index a543ad9..c40cb97 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -158,9 +158,18 @@ package body Switch.B is elsif Underscore then Set_Underscored_Debug_Flag (C); + if Debug_Flag_Underscore_C then Enable_CUDA_Expansion := True; end if; + if Debug_Flag_Underscore_D then + Enable_CUDA_Device_Expansion := True; + end if; + if Enable_CUDA_Expansion and Enable_CUDA_Device_Expansion + then + Bad_Switch (Switch_Chars); + end if; + Underscore := False; -- letter diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb index 921c1d2..248298a 100644 --- a/gcc/ada/uintp.adb +++ b/gcc/ada/uintp.adb @@ -300,11 +300,9 @@ package body Uintp is function Better_In_Hex return Boolean is T16 : constant Valid_Uint := Uint_2**Int'(16); - A : Valid_Uint; + A : Valid_Uint := UI_Abs (Input); begin - A := UI_Abs (Input); - -- Small values up to 2**16 can always be in decimal if A < T16 then diff --git a/gcc/analyzer/ChangeLog b/gcc/analyzer/ChangeLog index 3ad3096..ea6d5ee 100644 --- a/gcc/analyzer/ChangeLog +++ b/gcc/analyzer/ChangeLog @@ -1,3 +1,136 @@ +2022-09-11 Tim Lange <mail@tim-lange.me> + + PR analyzer/106845 + * region-model.cc (region_model::check_region_bounds): + Bail out if 0 bytes were accessed. + * store.cc (byte_range::dump_to_pp): + Add special case for empty ranges. + (byte_range::exceeds_p): Restrict to non-empty ranges. + (byte_range::falls_short_of_p): Restrict to non-empty ranges. + * store.h (bit_range::empty_p): New function. + (bit_range::get_last_byte_offset): Restrict to non-empty ranges. + (byte_range::empty_p): New function. + (byte_range::get_last_byte_offset): Restrict to non-empty ranges. + +2022-09-09 David Malcolm <dmalcolm@redhat.com> + + * analyzer.opt (Wanalyzer-exposure-through-uninit-copy): New. + * checker-path.cc (region_creation_event::region_creation_event): + Add "capacity" and "kind" params. + (region_creation_event::get_desc): Generalize to different kinds + of event. + (checker_path::add_region_creation_event): Convert to... + (checker_path::add_region_creation_events): ...this. + * checker-path.h (enum rce_kind): New. + (region_creation_event::region_creation_event): Add "capacity" and + "kind" params. + (region_creation_event::m_capacity): New field. + (region_creation_event::m_rce_kind): New field. + (checker_path::add_region_creation_event): Convert to... + (checker_path::add_region_creation_events): ...this. + * diagnostic-manager.cc (diagnostic_manager::build_emission_path): + Update for multiple region creation events. + (diagnostic_manager::add_event_on_final_node): Likewise. + (diagnostic_manager::add_events_for_eedge): Likewise. + * region-model-impl-calls.cc (call_details::get_logger): New. + * region-model.cc: Define INCLUDE_MEMORY before including + "system.h". Include "gcc-rich-location.h". + (class record_layout): New. + (class exposure_through_uninit_copy): New. + (contains_uninit_p): New. + (region_model::maybe_complain_about_infoleak): New. + * region-model.h (call_details::get_logger): New decl. + (region_model::maybe_complain_about_infoleak): New decl. + (region_model::mark_as_tainted): New decl. + * sm-taint.cc (region_model::mark_as_tainted): New. + +2022-09-09 David Malcolm <dmalcolm@redhat.com> + + * analyzer.h (class known_function_manager): New forward decl. + (class known_function): New. + (plugin_analyzer_init_iface::register_known_function): New. + * engine.cc: Include "analyzer/known-function-manager.h". + (plugin_analyzer_init_impl::plugin_analyzer_init_impl): Add + known_fn_mgr param. + (plugin_analyzer_init_impl::register_state_machine): Add + LOC_SCOPE. + (plugin_analyzer_init_impl::register_known_function): New. + (plugin_analyzer_init_impl::m_known_fn_mgr): New. + (impl_run_checkers): Update plugin callback invocation to use + eng's known_function_manager. + * known-function-manager.cc: New file. + * known-function-manager.h: New file. + * region-model-manager.cc + (region_model_manager::region_model_manager): Pass logger to + m_known_fn_mgr's ctor. + * region-model.cc (region_model::update_for_zero_return): New. + (region_model::update_for_nonzero_return): New. + (maybe_simplify_upper_bound): New. + (region_model::maybe_get_copy_bounds): New. + (region_model::get_known_function): New. + (region_model::on_call_pre): Handle plugin-supplied known + functions. + * region-model.h: Include "analyzer/known-function-manager.h". + (region_model_manager::get_known_function_manager): New. + (region_model_manager::m_known_fn_mgr): New. + (call_details::get_model): New accessor. + (region_model::maybe_get_copy_bounds): New decl. + (region_model::update_for_zero_return): New decl. + (region_model::update_for_nonzero_return): New decl. + (region_model::get_known_function): New decl. + (region_model::get_known_function_manager): New. + +2022-09-08 Tim Lange <mail@tim-lange.me> + + PR analyzer/106625 + * analyzer.h (region_offset): Eliminate m_is_symbolic member. + * region-model-impl-calls.cc (region_model::impl_call_realloc): + Refine implementation to be more precise. + * region-model.cc (class symbolic_past_the_end): + Abstract diagnostic class to complain about accesses past the end + with symbolic values. + (class symbolic_buffer_overflow): + Concrete diagnostic class to complain about buffer overflows with + symbolic values. + (class symbolic_buffer_overread): + Concrete diagnostic class to complain about buffer overreads with + symbolic values. + (region_model::check_symbolic_bounds): New function. + (maybe_get_integer_cst_tree): New helper function. + (region_model::check_region_bounds): + Add call to check_symbolic_bounds if offset is not concrete. + (region_model::eval_condition_without_cm): + Add support for EQ_EXPR and GT_EXPR with binaryop_svalues. + (is_positive_svalue): New hleper function. + (region_model::symbolic_greater_than): + New function to handle GT_EXPR comparisons with symbolic values. + (region_model::structural_equality): New function to compare + whether two svalues are structured the same, i.e. evaluate to + the same value. + (test_struct): Reflect changes to region::calc_offset. + (test_var): Likewise. + (test_array_2): Likewise and add selftest with symbolic i. + * region-model.h (class region_model): Add check_symbolic_bounds, + symbolic_greater_than and structural_equality. + * region.cc (region::get_offset): + Reflect changes to region::calc_offset. + (region::calc_offset): + Compute the symbolic offset if the offset is not concrete. + (region::get_relative_symbolic_offset): New function to return the + symbolic offset in bytes relative to its parent. + (field_region::get_relative_symbolic_offset): Likewise. + (element_region::get_relative_symbolic_offset): Likewise. + (offset_region::get_relative_symbolic_offset): Likewise. + (bit_range_region::get_relative_symbolic_offset): Likewise. + * region.h: Add get_relative_symbolic_offset. + * store.cc (binding_key::make): + Reflect changes to region::calc_offset. + (binding_map::apply_ctor_val_to_range): Likewise. + (binding_map::apply_ctor_pair_to_child_region): Likewise. + (binding_cluster::bind_compound_sval): Likewise. + (binding_cluster::get_any_binding): Likewise. + (binding_cluster::maybe_get_compound_binding): Likewise. + 2022-09-05 Tim Lange <mail@tim-lange.me> * region-model-impl-calls.cc (region_model::impl_call_strcpy): diff --git a/gcc/analyzer/analyzer.h b/gcc/analyzer/analyzer.h index dcefc13..b325aee 100644 --- a/gcc/analyzer/analyzer.h +++ b/gcc/analyzer/analyzer.h @@ -113,6 +113,7 @@ class engine; class state_machine; class logger; class visitor; +class known_function_manager; /* Forward decls of functions. */ @@ -172,16 +173,17 @@ public: static region_offset make_concrete (const region *base_region, bit_offset_t offset) { - return region_offset (base_region, offset, false); + return region_offset (base_region, offset, NULL); } - static region_offset make_symbolic (const region *base_region) + static region_offset make_symbolic (const region *base_region, + const svalue *sym_offset) { - return region_offset (base_region, 0, true); + return region_offset (base_region, 0, sym_offset); } const region *get_base_region () const { return m_base_region; } - bool symbolic_p () const { return m_is_symbolic; } + bool symbolic_p () const { return m_sym_offset != NULL; } bit_offset_t get_bit_offset () const { @@ -189,34 +191,52 @@ public: return m_offset; } + const svalue *get_symbolic_byte_offset () const + { + gcc_assert (symbolic_p ()); + return m_sym_offset; + } + bool operator== (const region_offset &other) const { return (m_base_region == other.m_base_region && m_offset == other.m_offset - && m_is_symbolic == other.m_is_symbolic); + && m_sym_offset == other.m_sym_offset); } private: region_offset (const region *base_region, bit_offset_t offset, - bool is_symbolic) - : m_base_region (base_region), m_offset (offset), m_is_symbolic (is_symbolic) + const svalue *sym_offset) + : m_base_region (base_region), m_offset (offset), m_sym_offset (sym_offset) {} const region *m_base_region; bit_offset_t m_offset; - bool m_is_symbolic; + const svalue *m_sym_offset; }; extern location_t get_stmt_location (const gimple *stmt, function *fun); extern bool compat_types_p (tree src_type, tree dst_type); +/* Abstract base class for simulating the behavior of known functions, + supplied by plugins. */ + +class known_function +{ +public: + virtual ~known_function () {} + virtual void impl_call_pre (const call_details &cd) const = 0; +}; + /* Passed by pointer to PLUGIN_ANALYZER_INIT callbacks. */ class plugin_analyzer_init_iface { public: virtual void register_state_machine (state_machine *) = 0; + virtual void register_known_function (const char *name, + known_function *) = 0; virtual logger *get_logger () const = 0; }; diff --git a/gcc/analyzer/analyzer.opt b/gcc/analyzer/analyzer.opt index 437ea92..dbab3b8 100644 --- a/gcc/analyzer/analyzer.opt +++ b/gcc/analyzer/analyzer.opt @@ -70,6 +70,10 @@ Wanalyzer-exposure-through-output-file Common Var(warn_analyzer_exposure_through_output_file) Init(1) Warning Warn about code paths in which sensitive data is written to a file. +Wanalyzer-exposure-through-uninit-copy +Common Var(warn_analyzer_exposure_through_uninit_copy) Init(1) Warning +Warn about code paths in which sensitive data is copied across a security boundary. + Wanalyzer-fd-access-mode-mismatch Common Var(warn_analyzer_fd_mode_mismatch) Init(1) Warning Warn about code paths in which read on a write-only file descriptor is attempted, or vice versa. diff --git a/gcc/analyzer/checker-path.cc b/gcc/analyzer/checker-path.cc index 273f40d..22bae2f 100644 --- a/gcc/analyzer/checker-path.cc +++ b/gcc/analyzer/checker-path.cc @@ -288,16 +288,25 @@ statement_event::get_desc (bool) const /* class region_creation_event : public checker_event. */ region_creation_event::region_creation_event (const region *reg, + tree capacity, + enum rce_kind kind, location_t loc, tree fndecl, int depth) : checker_event (EK_REGION_CREATION, loc, fndecl, depth), - m_reg (reg) + m_reg (reg), + m_capacity (capacity), + m_rce_kind (kind) { + if (m_rce_kind == RCE_CAPACITY) + gcc_assert (capacity); } /* Implementation of diagnostic_event::get_desc vfunc for - region_creation_event. */ + region_creation_event. + There are effectively 3 kinds of region_region_event, to + avoid combinatorial explosion by trying to convy the + information in a single message. */ label_text region_creation_event::get_desc (bool can_colorize) const @@ -311,14 +320,50 @@ region_creation_event::get_desc (bool can_colorize) const return custom_desc; } - switch (m_reg->get_memory_space ()) + switch (m_rce_kind) { default: - return label_text::borrow ("region created here"); - case MEMSPACE_STACK: - return label_text::borrow ("region created on stack here"); - case MEMSPACE_HEAP: - return label_text::borrow ("region created on heap here"); + gcc_unreachable (); + + case RCE_MEM_SPACE: + switch (m_reg->get_memory_space ()) + { + default: + return label_text::borrow ("region created here"); + case MEMSPACE_STACK: + return label_text::borrow ("region created on stack here"); + case MEMSPACE_HEAP: + return label_text::borrow ("region created on heap here"); + } + break; + + case RCE_CAPACITY: + gcc_assert (m_capacity); + if (TREE_CODE (m_capacity) == INTEGER_CST) + { + unsigned HOST_WIDE_INT hwi = tree_to_uhwi (m_capacity); + if (hwi == 1) + return make_label_text (can_colorize, + "capacity: %wu byte", hwi); + else + return make_label_text (can_colorize, + "capacity: %wu bytes", hwi); + } + else + return make_label_text (can_colorize, + "capacity: %qE bytes", m_capacity); + + case RCE_DEBUG: + { + pretty_printer pp; + pp_format_decoder (&pp) = default_tree_printer; + pp_string (&pp, "region creation: "); + m_reg->dump_to_pp (&pp, true); + if (m_capacity) + pp_printf (&pp, " capacity: %qE", m_capacity); + return label_text::take (xstrdup (pp_formatted_text (&pp))); + } + break; } } @@ -1207,15 +1252,33 @@ checker_path::debug () const } } -/* Add region_creation_event instance to this path for REG, - describing whether REG is on the stack or heap. */ +/* Add region_creation_event instances to this path for REG, + describing whether REG is on the stack or heap and what + its capacity is (if known). + If DEBUG is true, also create an RCE_DEBUG event. */ void -checker_path::add_region_creation_event (const region *reg, - location_t loc, - tree fndecl, int depth) +checker_path::add_region_creation_events (const region *reg, + const region_model *model, + location_t loc, + tree fndecl, int depth, + bool debug) { - add_event (new region_creation_event (reg, loc, fndecl, depth)); + tree capacity = NULL_TREE; + if (model) + if (const svalue *capacity_sval = model->get_capacity (reg)) + capacity = model->get_representative_tree (capacity_sval); + + add_event (new region_creation_event (reg, capacity, RCE_MEM_SPACE, + loc, fndecl, depth)); + + if (capacity) + add_event (new region_creation_event (reg, capacity, RCE_CAPACITY, + loc, fndecl, depth)); + + if (debug) + add_event (new region_creation_event (reg, capacity, RCE_DEBUG, + loc, fndecl, depth)); } /* Add a warning_event to the end of this path. */ diff --git a/gcc/analyzer/checker-path.h b/gcc/analyzer/checker-path.h index 8e48d8a..5d00934 100644 --- a/gcc/analyzer/checker-path.h +++ b/gcc/analyzer/checker-path.h @@ -210,19 +210,43 @@ public: const program_state m_dst_state; }; +/* There are too many combinations to express region creation in one message, + so we emit multiple region_creation_event instances when each pertinent + region is created. + + This enum distinguishes between the different messages. */ + +enum rce_kind +{ + /* Generate a message based on the memory space of the region + e.g. "region created on stack here". */ + RCE_MEM_SPACE, + + /* Generate a message based on the capacity of the region + e.g. "capacity: 100 bytes". */ + RCE_CAPACITY, + + /* Generate a debug message. */ + RCE_DEBUG +}; + /* A concrete event subclass describing the creation of a region that - is significant for a diagnostic e.g. "region created on stack here". */ + is significant for a diagnostic. */ class region_creation_event : public checker_event { public: region_creation_event (const region *reg, + tree capacity, + enum rce_kind kind, location_t loc, tree fndecl, int depth); label_text get_desc (bool can_colorize) const final override; private: const region *m_reg; + tree m_capacity; + enum rce_kind m_rce_kind; }; /* An event subclass describing the entry to a function. */ @@ -632,9 +656,11 @@ public: m_events[idx] = new_event; } - void add_region_creation_event (const region *reg, - location_t loc, - tree fndecl, int depth); + void add_region_creation_events (const region *reg, + const region_model *model, + location_t loc, + tree fndecl, int depth, + bool debug); void add_final_event (const state_machine *sm, const exploded_node *enode, const gimple *stmt, diff --git a/gcc/analyzer/diagnostic-manager.cc b/gcc/analyzer/diagnostic-manager.cc index fded828..2d185a1 100644 --- a/gcc/analyzer/diagnostic-manager.cc +++ b/gcc/analyzer/diagnostic-manager.cc @@ -1460,11 +1460,12 @@ diagnostic_manager::build_emission_path (const path_builder &pb, if (DECL_P (decl) && DECL_SOURCE_LOCATION (decl) != UNKNOWN_LOCATION) { - emission_path->add_region_creation_event - (reg, + emission_path->add_region_creation_events + (reg, NULL, DECL_SOURCE_LOCATION (decl), NULL_TREE, - 0); + 0, + m_verbosity > 3); } } } @@ -1524,11 +1525,13 @@ diagnostic_manager::add_event_on_final_node (const exploded_node *final_enode, break; case RK_HEAP_ALLOCATED: case RK_ALLOCA: - emission_path->add_region_creation_event + emission_path->add_region_creation_events (reg, - src_point.get_location (), - src_point.get_fndecl (), - src_stack_depth); + dst_model, + src_point.get_location (), + src_point.get_fndecl (), + src_stack_depth, + false); emitted = true; break; } @@ -1939,11 +1942,12 @@ diagnostic_manager::add_events_for_eedge (const path_builder &pb, if (DECL_P (decl) && DECL_SOURCE_LOCATION (decl) != UNKNOWN_LOCATION) { - emission_path->add_region_creation_event - (reg, + emission_path->add_region_creation_events + (reg, dst_state.m_region_model, DECL_SOURCE_LOCATION (decl), dst_point.get_fndecl (), - dst_stack_depth); + dst_stack_depth, + m_verbosity > 3); } } } @@ -2033,11 +2037,12 @@ diagnostic_manager::add_events_for_eedge (const path_builder &pb, break; case RK_HEAP_ALLOCATED: case RK_ALLOCA: - emission_path->add_region_creation_event - (reg, + emission_path->add_region_creation_events + (reg, dst_model, src_point.get_location (), src_point.get_fndecl (), - src_stack_depth); + src_stack_depth, + m_verbosity > 3); break; } } diff --git a/gcc/analyzer/engine.cc b/gcc/analyzer/engine.cc index e8db00d..742ac02 100644 --- a/gcc/analyzer/engine.cc +++ b/gcc/analyzer/engine.cc @@ -71,6 +71,7 @@ along with GCC; see the file COPYING3. If not see #include "stringpool.h" #include "attribs.h" #include "tree-dfa.h" +#include "analyzer/known-function-manager.h" /* For an overview, see gcc/doc/analyzer.texi. */ @@ -5813,16 +5814,26 @@ class plugin_analyzer_init_impl : public plugin_analyzer_init_iface { public: plugin_analyzer_init_impl (auto_delete_vec <state_machine> *checkers, + known_function_manager *known_fn_mgr, logger *logger) : m_checkers (checkers), + m_known_fn_mgr (known_fn_mgr), m_logger (logger) {} void register_state_machine (state_machine *sm) final override { + LOG_SCOPE (m_logger); m_checkers->safe_push (sm); } + void register_known_function (const char *name, + known_function *kf) final override + { + LOG_SCOPE (m_logger); + m_known_fn_mgr->add (name, kf); + } + logger *get_logger () const final override { return m_logger; @@ -5830,6 +5841,7 @@ public: private: auto_delete_vec <state_machine> *m_checkers; + known_function_manager *m_known_fn_mgr; logger *m_logger; }; @@ -5885,7 +5897,9 @@ impl_run_checkers (logger *logger) auto_delete_vec <state_machine> checkers; make_checkers (checkers, logger); - plugin_analyzer_init_impl data (&checkers, logger); + plugin_analyzer_init_impl data (&checkers, + eng.get_known_function_manager (), + logger); invoke_plugin_callbacks (PLUGIN_ANALYZER_INIT, &data); if (logger) diff --git a/gcc/analyzer/known-function-manager.cc b/gcc/analyzer/known-function-manager.cc new file mode 100644 index 0000000..f0fd4fc --- /dev/null +++ b/gcc/analyzer/known-function-manager.cc @@ -0,0 +1,78 @@ +/* Support for plugin-supplied behaviors of known functions. + Copyright (C) 2022 Free Software Foundation, Inc. + Contributed by David Malcolm <dmalcolm@redhat.com>. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GCC is distributed in the hope that it will be useful, but +WITHOUT 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 +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "function.h" +#include "analyzer/analyzer.h" +#include "diagnostic-core.h" +#include "analyzer/analyzer-logging.h" +#include "stringpool.h" +#include "analyzer/known-function-manager.h" + +#if ENABLE_ANALYZER + +namespace ana { + +/* class known_function_manager : public log_user. */ + +known_function_manager::known_function_manager (logger *logger) +: log_user (logger) +{ +} + +known_function_manager::~known_function_manager () +{ + /* Delete all owned kfs. */ + for (auto iter : m_map_id_to_kf) + delete iter.second; +} + +void +known_function_manager::add (const char *name, known_function *kf) +{ + LOG_FUNC_1 (get_logger (), "registering %s", name); + tree id = get_identifier (name); + m_map_id_to_kf.put (id, kf); +} + +const known_function * +known_function_manager::get_by_identifier (tree identifier) +{ + known_function **slot = m_map_id_to_kf.get (identifier); + if (slot) + return *slot; + else + return NULL; +} + +const known_function * +known_function_manager::get_by_fndecl (tree fndecl) +{ + if (tree identifier = DECL_NAME (fndecl)) + return get_by_identifier (identifier); + return NULL; +} + +} // namespace ana + +#endif /* #if ENABLE_ANALYZER */ diff --git a/gcc/analyzer/known-function-manager.h b/gcc/analyzer/known-function-manager.h new file mode 100644 index 0000000..fbde853 --- /dev/null +++ b/gcc/analyzer/known-function-manager.h @@ -0,0 +1,45 @@ +/* Support for plugin-supplied behaviors of known functions. + Copyright (C) 2022 Free Software Foundation, Inc. + Contributed by David Malcolm <dmalcolm@redhat.com>. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GCC is distributed in the hope that it will be useful, but +WITHOUT 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 +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#ifndef GCC_ANALYZER_KNOWN_FUNCTION_MANAGER_H +#define GCC_ANALYZER_KNOWN_FUNCTION_MANAGER_H + +namespace ana { + +class known_function_manager : public log_user +{ +public: + known_function_manager (logger *logger); + ~known_function_manager (); + void add (const char *name, known_function *kf); + const known_function *get_by_identifier (tree identifier); + const known_function *get_by_fndecl (tree fndecl); + +private: + DISABLE_COPY_AND_ASSIGN (known_function_manager); + + /* Map from identifier to known_function instance. + Has ownership of the latter. */ + hash_map<tree, known_function *> m_map_id_to_kf; +}; + +} // namespace ana + +#endif /* GCC_ANALYZER_KNOWN_FUNCTION_MANAGER_H */ diff --git a/gcc/analyzer/region-model-impl-calls.cc b/gcc/analyzer/region-model-impl-calls.cc index 3790eaf..71fb277 100644 --- a/gcc/analyzer/region-model-impl-calls.cc +++ b/gcc/analyzer/region-model-impl-calls.cc @@ -91,6 +91,17 @@ call_details::get_manager () const return m_model->get_manager (); } +/* Get any logger associated with this object. */ + +logger * +call_details::get_logger () const +{ + if (m_ctxt) + return m_ctxt->get_logger (); + else + return NULL; +} + /* Get any uncertainty_t associated with the region_model_context. */ uncertainty_t * @@ -850,7 +861,7 @@ region_model::impl_call_realloc (const call_details &cd) if (old_size_sval) { const svalue *copied_size_sval - = get_copied_size (old_size_sval, new_size_sval); + = get_copied_size (model, old_size_sval, new_size_sval); const region *copied_old_reg = model->m_mgr->get_sized_region (freed_reg, NULL, copied_size_sval); @@ -896,35 +907,22 @@ region_model::impl_call_realloc (const call_details &cd) private: /* Return the lesser of OLD_SIZE_SVAL and NEW_SIZE_SVAL. - If either one is symbolic, the symbolic svalue is returned. */ - const svalue *get_copied_size (const svalue *old_size_sval, + If unknown, OLD_SIZE_SVAL is returned. */ + const svalue *get_copied_size (region_model *model, + const svalue *old_size_sval, const svalue *new_size_sval) const { - tree old_size_cst = old_size_sval->maybe_get_constant (); - tree new_size_cst = new_size_sval->maybe_get_constant (); - - if (old_size_cst && new_size_cst) + tristate res + = model->eval_condition (old_size_sval, GT_EXPR, new_size_sval); + switch (res.get_value ()) { - /* Both are constants and comparable. */ - tree cmp = fold_binary (LT_EXPR, boolean_type_node, - old_size_cst, new_size_cst); - - if (cmp == boolean_true_node) - return old_size_sval; - else - return new_size_sval; - } - else if (new_size_cst) - { - /* OLD_SIZE_SVAL is symbolic, so return that. */ - return old_size_sval; - } - else - { - /* NEW_SIZE_SVAL is symbolic or both are symbolic. - Return NEW_SIZE_SVAL, because implementations of realloc - probably only moves the buffer if the new size is larger. */ + case tristate::TS_TRUE: return new_size_sval; + case tristate::TS_FALSE: + case tristate::TS_UNKNOWN: + return old_size_sval; + default: + gcc_unreachable (); } } }; diff --git a/gcc/analyzer/region-model-manager.cc b/gcc/analyzer/region-model-manager.cc index 17713b0..cbda77f 100644 --- a/gcc/analyzer/region-model-manager.cc +++ b/gcc/analyzer/region-model-manager.cc @@ -81,7 +81,8 @@ region_model_manager::region_model_manager (logger *logger) m_globals_region (alloc_region_id (), &m_root_region), m_globals_map (), m_store_mgr (this), - m_range_mgr (new bounded_ranges_manager ()) + m_range_mgr (new bounded_ranges_manager ()), + m_known_fn_mgr (logger) { } diff --git a/gcc/analyzer/region-model.cc b/gcc/analyzer/region-model.cc index e84087a..22c5287 100644 --- a/gcc/analyzer/region-model.cc +++ b/gcc/analyzer/region-model.cc @@ -19,6 +19,7 @@ along with GCC; see the file COPYING3. If not see <http://www.gnu.org/licenses/>. */ #include "config.h" +#define INCLUDE_MEMORY #include "system.h" #include "coretypes.h" #include "tree.h" @@ -74,6 +75,7 @@ along with GCC; see the file COPYING3. If not see #include "ssa-iterators.h" #include "calls.h" #include "is-a.h" +#include "gcc-rich-location.h" #if ENABLE_ANALYZER @@ -1268,7 +1270,7 @@ region_model::on_stmt_pre (const gimple *stmt, } } -/* Abstract base class for all out-of-bounds warnings. */ +/* Abstract base class for all out-of-bounds warnings with concrete values. */ class out_of_bounds : public pending_diagnostic_subclass<out_of_bounds> { @@ -1591,49 +1593,288 @@ public: } }; +/* Abstract class to complain about out-of-bounds read/writes where + the values are symbolic. */ + +class symbolic_past_the_end + : public pending_diagnostic_subclass<symbolic_past_the_end> +{ +public: + symbolic_past_the_end (const region *reg, tree diag_arg, tree offset, + tree num_bytes, tree capacity) + : m_reg (reg), m_diag_arg (diag_arg), m_offset (offset), + m_num_bytes (num_bytes), m_capacity (capacity) + {} + + const char *get_kind () const final override + { + return "symbolic_past_the_end"; + } + + bool operator== (const symbolic_past_the_end &other) const + { + return m_reg == other.m_reg + && pending_diagnostic::same_tree_p (m_diag_arg, other.m_diag_arg) + && pending_diagnostic::same_tree_p (m_offset, other.m_offset) + && pending_diagnostic::same_tree_p (m_num_bytes, other.m_num_bytes) + && pending_diagnostic::same_tree_p (m_capacity, other.m_capacity); + } + + int get_controlling_option () const final override + { + return OPT_Wanalyzer_out_of_bounds; + } + + void mark_interesting_stuff (interesting_t *interest) final override + { + interest->add_region_creation (m_reg); + } + + label_text + describe_region_creation_event (const evdesc::region_creation &ev) final + override + { + if (m_capacity) + return ev.formatted_print ("capacity is %qE bytes", m_capacity); + + return label_text (); + } + + label_text + describe_final_event (const evdesc::final_event &ev) final override + { + const char *byte_str; + if (pending_diagnostic::same_tree_p (m_num_bytes, integer_one_node)) + byte_str = "byte"; + else + byte_str = "bytes"; + + if (m_offset) + { + if (m_num_bytes && TREE_CODE (m_num_bytes) == INTEGER_CST) + { + if (m_diag_arg) + return ev.formatted_print ("%s of %E %s at offset %qE" + " exceeds %qE", m_dir_str, + m_num_bytes, byte_str, + m_offset, m_diag_arg); + else + return ev.formatted_print ("%s of %E %s at offset %qE" + " exceeds the buffer", m_dir_str, + m_num_bytes, byte_str, m_offset); + } + else if (m_num_bytes) + { + if (m_diag_arg) + return ev.formatted_print ("%s of %qE %s at offset %qE" + " exceeds %qE", m_dir_str, + m_num_bytes, byte_str, + m_offset, m_diag_arg); + else + return ev.formatted_print ("%s of %qE %s at offset %qE" + " exceeds the buffer", m_dir_str, + m_num_bytes, byte_str, m_offset); + } + else + { + if (m_diag_arg) + return ev.formatted_print ("%s at offset %qE exceeds %qE", + m_dir_str, m_offset, m_diag_arg); + else + return ev.formatted_print ("%s at offset %qE exceeds the" + " buffer", m_dir_str, m_offset); + } + } + if (m_diag_arg) + return ev.formatted_print ("out-of-bounds %s on %qE", + m_dir_str, m_diag_arg); + return ev.formatted_print ("out-of-bounds %s", m_dir_str); + } + +protected: + const region *m_reg; + tree m_diag_arg; + tree m_offset; + tree m_num_bytes; + tree m_capacity; + const char *m_dir_str; +}; + +/* Concrete subclass to complain about overflows with symbolic values. */ + +class symbolic_buffer_overflow : public symbolic_past_the_end +{ +public: + symbolic_buffer_overflow (const region *reg, tree diag_arg, tree offset, + tree num_bytes, tree capacity) + : symbolic_past_the_end (reg, diag_arg, offset, num_bytes, capacity) + { + m_dir_str = "write"; + } + + bool emit (rich_location *rich_loc) final override + { + diagnostic_metadata m; + switch (m_reg->get_memory_space ()) + { + default: + m.add_cwe (787); + return warning_meta (rich_loc, m, get_controlling_option (), + "buffer overflow"); + case MEMSPACE_STACK: + m.add_cwe (121); + return warning_meta (rich_loc, m, get_controlling_option (), + "stack-based buffer overflow"); + case MEMSPACE_HEAP: + m.add_cwe (122); + return warning_meta (rich_loc, m, get_controlling_option (), + "heap-based buffer overflow"); + } + } +}; + +/* Concrete subclass to complain about overreads with symbolic values. */ + +class symbolic_buffer_overread : public symbolic_past_the_end +{ +public: + symbolic_buffer_overread (const region *reg, tree diag_arg, tree offset, + tree num_bytes, tree capacity) + : symbolic_past_the_end (reg, diag_arg, offset, num_bytes, capacity) + { + m_dir_str = "read"; + } + + bool emit (rich_location *rich_loc) final override + { + diagnostic_metadata m; + m.add_cwe (126); + return warning_meta (rich_loc, m, get_controlling_option (), + "buffer overread"); + } +}; + +/* Check whether an access is past the end of the BASE_REG. */ + +void region_model::check_symbolic_bounds (const region *base_reg, + const svalue *sym_byte_offset, + const svalue *num_bytes_sval, + const svalue *capacity, + enum access_direction dir, + region_model_context *ctxt) const +{ + gcc_assert (ctxt); + + const svalue *next_byte + = m_mgr->get_or_create_binop (num_bytes_sval->get_type (), PLUS_EXPR, + sym_byte_offset, num_bytes_sval); + + if (eval_condition_without_cm (next_byte, GT_EXPR, capacity).is_true ()) + { + tree diag_arg = get_representative_tree (base_reg); + tree offset_tree = get_representative_tree (sym_byte_offset); + tree num_bytes_tree = get_representative_tree (num_bytes_sval); + tree capacity_tree = get_representative_tree (capacity); + switch (dir) + { + default: + gcc_unreachable (); + break; + case DIR_READ: + ctxt->warn (new symbolic_buffer_overread (base_reg, diag_arg, + offset_tree, + num_bytes_tree, + capacity_tree)); + break; + case DIR_WRITE: + ctxt->warn (new symbolic_buffer_overflow (base_reg, diag_arg, + offset_tree, + num_bytes_tree, + capacity_tree)); + break; + } + } +} + +static tree +maybe_get_integer_cst_tree (const svalue *sval) +{ + tree cst_tree = sval->maybe_get_constant (); + if (cst_tree && TREE_CODE (cst_tree) == INTEGER_CST) + return cst_tree; + + return NULL_TREE; +} + /* May complain when the access on REG is out-of-bounds. */ -void region_model::check_region_bounds (const region *reg, - enum access_direction dir, - region_model_context *ctxt) const +void +region_model::check_region_bounds (const region *reg, + enum access_direction dir, + region_model_context *ctxt) const { gcc_assert (ctxt); - region_offset reg_offset = reg->get_offset (); + /* Get the offset. */ + region_offset reg_offset = reg->get_offset (m_mgr); const region *base_reg = reg_offset.get_base_region (); - /* Bail out on symbolic offsets or symbolic regions. + /* Bail out on symbolic regions. (e.g. because the analyzer did not see previous offsets on the latter, it might think that a negative access is before the buffer). */ - if (reg_offset.symbolic_p () || base_reg->symbolic_p ()) + if (base_reg->symbolic_p ()) return; - byte_offset_t offset_unsigned - = reg_offset.get_bit_offset () >> LOG2_BITS_PER_UNIT; + + /* Find out how many bytes were accessed. */ + const svalue *num_bytes_sval = reg->get_byte_size_sval (m_mgr); + tree num_bytes_tree = maybe_get_integer_cst_tree (num_bytes_sval); + /* Bail out if 0 bytes are accessed. */ + if (num_bytes_tree && zerop (num_bytes_tree)) + return; + + /* Get the capacity of the buffer. */ + const svalue *capacity = get_capacity (base_reg); + tree cst_capacity_tree = maybe_get_integer_cst_tree (capacity); + /* The constant offset from a pointer is represented internally as a sizetype but should be interpreted as a signed value here. The statement below - converts the offset to a signed integer with the same precision the - sizetype has on the target system. + converts the offset from bits to bytes and then to a signed integer with + the same precision the sizetype has on the target system. For example, this is needed for out-of-bounds-3.c test1 to pass when compiled with a 64-bit gcc build targeting 32-bit systems. */ - byte_offset_t offset - = offset_unsigned.to_shwi (TYPE_PRECISION (size_type_node)); - - /* Find out how many bytes were accessed. */ - const svalue *num_bytes_sval = reg->get_byte_size_sval (m_mgr); - tree num_bytes_tree = num_bytes_sval->maybe_get_constant (); - if (!num_bytes_tree || TREE_CODE (num_bytes_tree) != INTEGER_CST) - /* If we do not know how many bytes were read/written, - assume that at least one byte was read/written. */ - num_bytes_tree = integer_one_node; + byte_offset_t offset; + if (!reg_offset.symbolic_p ()) + offset = wi::sext (reg_offset.get_bit_offset () >> LOG2_BITS_PER_UNIT, + TYPE_PRECISION (size_type_node)); + + /* If either the offset or the number of bytes accessed are symbolic, + we have to reason about symbolic values. */ + if (reg_offset.symbolic_p () || !num_bytes_tree) + { + const svalue* byte_offset_sval; + if (!reg_offset.symbolic_p ()) + { + tree offset_tree = wide_int_to_tree (integer_type_node, offset); + byte_offset_sval + = m_mgr->get_or_create_constant_svalue (offset_tree); + } + else + byte_offset_sval = reg_offset.get_symbolic_byte_offset (); + check_symbolic_bounds (base_reg, byte_offset_sval, num_bytes_sval, + capacity, dir, ctxt); + return; + } + /* Otherwise continue to check with concrete values. */ byte_range out (0, 0); /* NUM_BYTES_TREE should always be interpreted as unsigned. */ - byte_range read_bytes (offset, wi::to_offset (num_bytes_tree).to_uhwi ()); + byte_offset_t num_bytes_unsigned = wi::to_offset (num_bytes_tree); + byte_range read_bytes (offset, num_bytes_unsigned); /* If read_bytes has a subset < 0, we do have an underflow. */ if (read_bytes.falls_short_of_p (0, &out)) { - tree diag_arg = get_representative_tree (reg->get_base_region ()); + tree diag_arg = get_representative_tree (base_reg); switch (dir) { default: @@ -1648,9 +1889,10 @@ void region_model::check_region_bounds (const region *reg, } } - const svalue *capacity = get_capacity (base_reg); - tree cst_capacity_tree = capacity->maybe_get_constant (); - if (!cst_capacity_tree || TREE_CODE (cst_capacity_tree) != INTEGER_CST) + /* For accesses past the end, we do need a concrete capacity. No need to + do a symbolic check here because the inequality check does not reason + whether constants are greater than symbolic values. */ + if (!cst_capacity_tree) return; byte_range buffer (0, wi::to_offset (cst_capacity_tree)); @@ -1659,7 +1901,7 @@ void region_model::check_region_bounds (const region *reg, { tree byte_bound = wide_int_to_tree (size_type_node, buffer.get_next_byte_offset ()); - tree diag_arg = get_representative_tree (reg->get_base_region ()); + tree diag_arg = get_representative_tree (base_reg); switch (dir) { @@ -1731,6 +1973,110 @@ maybe_get_const_fn_result (const call_details &cd) return sval; } +/* Update this model for an outcome of a call that returns zero. + If UNMERGEABLE, then make the result unmergeable, e.g. to prevent + the state-merger code from merging success and failure outcomes. */ + +void +region_model::update_for_zero_return (const call_details &cd, + bool unmergeable) +{ + if (!cd.get_lhs_type ()) + return; + const svalue *result + = m_mgr->get_or_create_int_cst (cd.get_lhs_type (), 0); + if (unmergeable) + result = m_mgr->get_or_create_unmergeable (result); + set_value (cd.get_lhs_region (), result, cd.get_ctxt ()); +} + +/* Update this model for an outcome of a call that returns non-zero. */ + +void +region_model::update_for_nonzero_return (const call_details &cd) +{ + if (!cd.get_lhs_type ()) + return; + const svalue *zero + = m_mgr->get_or_create_int_cst (cd.get_lhs_type (), 0); + const svalue *result + = get_store_value (cd.get_lhs_region (), cd.get_ctxt ()); + add_constraint (result, NE_EXPR, zero, cd.get_ctxt ()); +} + +/* Subroutine of region_model::maybe_get_copy_bounds. + The Linux kernel commonly uses + min_t([unsigned] long, VAR, sizeof(T)); + to set an upper bound on the size of a copy_to_user. + Attempt to simplify such sizes by trying to get the upper bound as a + constant. + Return the simplified svalue if possible, or NULL otherwise. */ + +static const svalue * +maybe_simplify_upper_bound (const svalue *num_bytes_sval, + region_model_manager *mgr) +{ + tree type = num_bytes_sval->get_type (); + while (const svalue *raw = num_bytes_sval->maybe_undo_cast ()) + num_bytes_sval = raw; + if (const binop_svalue *binop_sval = num_bytes_sval->dyn_cast_binop_svalue ()) + if (binop_sval->get_op () == MIN_EXPR) + if (binop_sval->get_arg1 ()->get_kind () == SK_CONSTANT) + { + return mgr->get_or_create_cast (type, binop_sval->get_arg1 ()); + /* TODO: we might want to also capture the constraint + when recording the diagnostic, or note that we're using + the upper bound. */ + } + return NULL; +} + +/* Attempt to get an upper bound for the size of a copy when simulating a + copy function. + + NUM_BYTES_SVAL is the symbolic value for the size of the copy. + Use it if it's constant, otherwise try to simplify it. Failing + that, use the size of SRC_REG if constant. + + Return a symbolic value for an upper limit on the number of bytes + copied, or NULL if no such value could be determined. */ + +const svalue * +region_model::maybe_get_copy_bounds (const region *src_reg, + const svalue *num_bytes_sval) +{ + if (num_bytes_sval->maybe_get_constant ()) + return num_bytes_sval; + + if (const svalue *simplified + = maybe_simplify_upper_bound (num_bytes_sval, m_mgr)) + num_bytes_sval = simplified; + + if (num_bytes_sval->maybe_get_constant ()) + return num_bytes_sval; + + /* For now, try just guessing the size as the capacity of the + base region of the src. + This is a hack; we might get too large a value. */ + const region *src_base_reg = src_reg->get_base_region (); + num_bytes_sval = get_capacity (src_base_reg); + + if (num_bytes_sval->maybe_get_constant ()) + return num_bytes_sval; + + /* Non-constant: give up. */ + return NULL; +} + +/* Get any known_function for FNDECL, or NULL if there is none. */ + +const known_function * +region_model::get_known_function (tree fndecl) const +{ + known_function_manager *known_fn_mgr = m_mgr->get_known_function_manager (); + return known_fn_mgr->get_by_fndecl (fndecl); +} + /* Update this model for the CALL stmt, using CTXT to report any diagnostics - the first half. @@ -1987,6 +2333,11 @@ region_model::on_call_pre (const gcall *call, region_model_context *ctxt, { /* Handle in "on_call_post". */ } + else if (const known_function *kf = get_known_function (callee_fndecl)) + { + kf->impl_call_pre (cd); + return false; + } else if (!fndecl_has_gimple_body_p (callee_fndecl) && (!(callee_fndecl_flags & (ECF_CONST | ECF_PURE))) && !fndecl_built_in_p (callee_fndecl)) @@ -3907,6 +4258,49 @@ region_model::eval_condition_without_cm (const svalue *lhs, return res; } + /* Handle comparisons between two svalues with more than one operand. */ + if (const binop_svalue *binop = lhs->dyn_cast_binop_svalue ()) + { + switch (op) + { + default: + break; + case EQ_EXPR: + { + /* TODO: binops can be equal even if they are not structurally + equal in case of commutative operators. */ + tristate res = structural_equality (lhs, rhs); + if (res.is_true ()) + return res; + } + break; + case LE_EXPR: + { + tristate res = structural_equality (lhs, rhs); + if (res.is_true ()) + return res; + } + break; + case GE_EXPR: + { + tristate res = structural_equality (lhs, rhs); + if (res.is_true ()) + return res; + res = symbolic_greater_than (binop, rhs); + if (res.is_true ()) + return res; + } + break; + case GT_EXPR: + { + tristate res = symbolic_greater_than (binop, rhs); + if (res.is_true ()) + return res; + } + break; + } + } + return tristate::TS_UNKNOWN; } @@ -3928,6 +4322,123 @@ region_model::compare_initial_and_pointer (const initial_svalue *init, return tristate::TS_UNKNOWN; } +/* Return true if SVAL is definitely positive. */ + +static bool +is_positive_svalue (const svalue *sval) +{ + if (tree cst = sval->maybe_get_constant ()) + return !zerop (cst) && get_range_pos_neg (cst) == 1; + tree type = sval->get_type (); + if (!type) + return false; + /* Consider a binary operation size_t + int. The analyzer wraps the int in + an unaryop_svalue, converting it to a size_t, but in the dynamic execution + the result is smaller than the first operand. Thus, we have to look if + the argument of the unaryop_svalue is also positive. */ + if (const unaryop_svalue *un_op = dyn_cast <const unaryop_svalue *> (sval)) + return CONVERT_EXPR_CODE_P (un_op->get_op ()) && TYPE_UNSIGNED (type) + && is_positive_svalue (un_op->get_arg ()); + return TYPE_UNSIGNED (type); +} + +/* Return true if A is definitely larger than B. + + Limitation: does not account for integer overflows and does not try to + return false, so it can not be used negated. */ + +tristate +region_model::symbolic_greater_than (const binop_svalue *bin_a, + const svalue *b) const +{ + if (bin_a->get_op () == PLUS_EXPR || bin_a->get_op () == MULT_EXPR) + { + /* Eliminate the right-hand side of both svalues. */ + if (const binop_svalue *bin_b = dyn_cast <const binop_svalue *> (b)) + if (bin_a->get_op () == bin_b->get_op () + && eval_condition_without_cm (bin_a->get_arg1 (), + GT_EXPR, + bin_b->get_arg1 ()).is_true () + && eval_condition_without_cm (bin_a->get_arg0 (), + GE_EXPR, + bin_b->get_arg0 ()).is_true ()) + return tristate (tristate::TS_TRUE); + + /* Otherwise, try to remove a positive offset or factor from BIN_A. */ + if (is_positive_svalue (bin_a->get_arg1 ()) + && eval_condition_without_cm (bin_a->get_arg0 (), + GE_EXPR, b).is_true ()) + return tristate (tristate::TS_TRUE); + } + return tristate::unknown (); +} + +/* Return true if A and B are equal structurally. + + Structural equality means that A and B are equal if the svalues A and B have + the same nodes at the same positions in the tree and the leafs are equal. + Equality for conjured_svalues and initial_svalues is determined by comparing + the pointers while constants are compared by value. That behavior is useful + to check for binaryop_svlaues that evaluate to the same concrete value but + might use one operand with a different type but the same constant value. + + For example, + binop_svalue (mult_expr, + initial_svalue (‘size_t’, decl_region (..., 'some_var')), + constant_svalue (‘size_t’, 4)) + and + binop_svalue (mult_expr, + initial_svalue (‘size_t’, decl_region (..., 'some_var'), + constant_svalue (‘sizetype’, 4)) + are structurally equal. A concrete C code example, where this occurs, can + be found in test7 of out-of-bounds-5.c. */ + +tristate +region_model::structural_equality (const svalue *a, const svalue *b) const +{ + /* If A and B are referentially equal, they are also structurally equal. */ + if (a == b) + return tristate (tristate::TS_TRUE); + + switch (a->get_kind ()) + { + default: + return tristate::unknown (); + /* SK_CONJURED and SK_INITIAL are already handled + by the referential equality above. */ + case SK_CONSTANT: + { + tree a_cst = a->maybe_get_constant (); + tree b_cst = b->maybe_get_constant (); + if (a_cst && b_cst) + return tristate (tree_int_cst_equal (a_cst, b_cst)); + } + return tristate (tristate::TS_FALSE); + case SK_UNARYOP: + { + const unaryop_svalue *un_a = as_a <const unaryop_svalue *> (a); + if (const unaryop_svalue *un_b = dyn_cast <const unaryop_svalue *> (b)) + return tristate (pending_diagnostic::same_tree_p (un_a->get_type (), + un_b->get_type ()) + && un_a->get_op () == un_b->get_op () + && structural_equality (un_a->get_arg (), + un_b->get_arg ())); + } + return tristate (tristate::TS_FALSE); + case SK_BINOP: + { + const binop_svalue *bin_a = as_a <const binop_svalue *> (a); + if (const binop_svalue *bin_b = dyn_cast <const binop_svalue *> (b)) + return tristate (bin_a->get_op () == bin_b->get_op () + && structural_equality (bin_a->get_arg0 (), + bin_b->get_arg0 ()) + && structural_equality (bin_a->get_arg1 (), + bin_b->get_arg1 ())); + } + return tristate (tristate::TS_FALSE); + } +} + /* Handle various constraints of the form: LHS: ((bool)INNER_LHS INNER_OP INNER_RHS)) OP : == or != @@ -5278,6 +5789,566 @@ region_model::unset_dynamic_extents (const region *reg) m_dynamic_extents.remove (reg); } +/* Information of the layout of a RECORD_TYPE, capturing it as a vector + of items, where each item is either a field or padding. */ + +class record_layout +{ +public: + /* An item within a record; either a field, or padding after a field. */ + struct item + { + public: + item (const bit_range &br, + tree field, + bool is_padding) + : m_bit_range (br), + m_field (field), + m_is_padding (is_padding) + { + } + + bit_offset_t get_start_bit_offset () const + { + return m_bit_range.get_start_bit_offset (); + } + bit_offset_t get_next_bit_offset () const + { + return m_bit_range.get_next_bit_offset (); + } + + bool contains_p (bit_offset_t offset) const + { + return m_bit_range.contains_p (offset); + } + + void dump_to_pp (pretty_printer *pp) const + { + if (m_is_padding) + pp_printf (pp, "padding after %qD", m_field); + else + pp_printf (pp, "%qD", m_field); + pp_string (pp, ", "); + m_bit_range.dump_to_pp (pp); + } + + bit_range m_bit_range; + tree m_field; + bool m_is_padding; + }; + + record_layout (tree record_type) + { + gcc_assert (TREE_CODE (record_type) == RECORD_TYPE); + + for (tree iter = TYPE_FIELDS (record_type); iter != NULL_TREE; + iter = DECL_CHAIN (iter)) + { + if (TREE_CODE (iter) == FIELD_DECL) + { + int iter_field_offset = int_bit_position (iter); + bit_size_t size_in_bits; + if (!int_size_in_bits (TREE_TYPE (iter), &size_in_bits)) + size_in_bits = 0; + + maybe_pad_to (iter_field_offset); + + /* Add field. */ + m_items.safe_push (item (bit_range (iter_field_offset, + size_in_bits), + iter, false)); + } + } + + /* Add any trailing padding. */ + bit_size_t size_in_bits; + if (int_size_in_bits (record_type, &size_in_bits)) + maybe_pad_to (size_in_bits); + } + + void dump_to_pp (pretty_printer *pp) const + { + unsigned i; + item *it; + FOR_EACH_VEC_ELT (m_items, i, it) + { + it->dump_to_pp (pp); + pp_newline (pp); + } + } + + DEBUG_FUNCTION void dump () const + { + pretty_printer pp; + pp_format_decoder (&pp) = default_tree_printer; + pp.buffer->stream = stderr; + dump_to_pp (&pp); + pp_flush (&pp); + } + + const record_layout::item *get_item_at (bit_offset_t offset) const + { + unsigned i; + item *it; + FOR_EACH_VEC_ELT (m_items, i, it) + if (it->contains_p (offset)) + return it; + return NULL; + } + +private: + /* Subroutine of ctor. Add padding item to NEXT_OFFSET if necessary. */ + + void maybe_pad_to (bit_offset_t next_offset) + { + if (m_items.length () > 0) + { + const item &last_item = m_items[m_items.length () - 1]; + bit_offset_t offset_after_last_item + = last_item.get_next_bit_offset (); + if (next_offset > offset_after_last_item) + { + bit_size_t padding_size + = next_offset - offset_after_last_item; + m_items.safe_push (item (bit_range (offset_after_last_item, + padding_size), + last_item.m_field, true)); + } + } + } + + auto_vec<item> m_items; +}; + +/* A subclass of pending_diagnostic for complaining about uninitialized data + being copied across a trust boundary to an untrusted output + (e.g. copy_to_user infoleaks in the Linux kernel). */ + +class exposure_through_uninit_copy + : public pending_diagnostic_subclass<exposure_through_uninit_copy> +{ +public: + exposure_through_uninit_copy (const region *src_region, + const region *dest_region, + const svalue *copied_sval) + : m_src_region (src_region), + m_dest_region (dest_region), + m_copied_sval (copied_sval) + { + gcc_assert (m_copied_sval->get_kind () == SK_POISONED + || m_copied_sval->get_kind () == SK_COMPOUND); + } + + const char *get_kind () const final override + { + return "exposure_through_uninit_copy"; + } + + bool operator== (const exposure_through_uninit_copy &other) const + { + return (m_src_region == other.m_src_region + && m_dest_region == other.m_dest_region + && m_copied_sval == other.m_copied_sval); + } + + int get_controlling_option () const final override + { + return OPT_Wanalyzer_exposure_through_uninit_copy; + } + + bool emit (rich_location *rich_loc) final override + { + diagnostic_metadata m; + /* CWE-200: Exposure of Sensitive Information to an Unauthorized Actor. */ + m.add_cwe (200); + enum memory_space mem_space = get_src_memory_space (); + bool warned; + switch (mem_space) + { + default: + warned = warning_meta + (rich_loc, m, get_controlling_option (), + "potential exposure of sensitive information" + " by copying uninitialized data across trust boundary"); + break; + case MEMSPACE_STACK: + warned = warning_meta + (rich_loc, m, get_controlling_option (), + "potential exposure of sensitive information" + " by copying uninitialized data from stack across trust boundary"); + break; + case MEMSPACE_HEAP: + warned = warning_meta + (rich_loc, m, get_controlling_option (), + "potential exposure of sensitive information" + " by copying uninitialized data from heap across trust boundary"); + break; + } + if (warned) + { + location_t loc = rich_loc->get_loc (); + inform_number_of_uninit_bits (loc); + complain_about_uninit_ranges (loc); + + if (mem_space == MEMSPACE_STACK) + maybe_emit_fixit_hint (); + } + return warned; + } + + label_text describe_final_event (const evdesc::final_event &) final override + { + enum memory_space mem_space = get_src_memory_space (); + switch (mem_space) + { + default: + return label_text::borrow ("uninitialized data copied here"); + + case MEMSPACE_STACK: + return label_text::borrow ("uninitialized data copied from stack here"); + + case MEMSPACE_HEAP: + return label_text::borrow ("uninitialized data copied from heap here"); + } + } + + void mark_interesting_stuff (interesting_t *interest) final override + { + if (m_src_region) + interest->add_region_creation (m_src_region); + } + +private: + enum memory_space get_src_memory_space () const + { + return m_src_region ? m_src_region->get_memory_space () : MEMSPACE_UNKNOWN; + } + + bit_size_t calc_num_uninit_bits () const + { + switch (m_copied_sval->get_kind ()) + { + default: + gcc_unreachable (); + break; + case SK_POISONED: + { + const poisoned_svalue *poisoned_sval + = as_a <const poisoned_svalue *> (m_copied_sval); + gcc_assert (poisoned_sval->get_poison_kind () == POISON_KIND_UNINIT); + + /* Give up if don't have type information. */ + if (m_copied_sval->get_type () == NULL_TREE) + return 0; + + bit_size_t size_in_bits; + if (int_size_in_bits (m_copied_sval->get_type (), &size_in_bits)) + return size_in_bits; + + /* Give up if we can't get the size of the type. */ + return 0; + } + break; + case SK_COMPOUND: + { + const compound_svalue *compound_sval + = as_a <const compound_svalue *> (m_copied_sval); + bit_size_t result = 0; + /* Find keys for uninit svals. */ + for (auto iter : *compound_sval) + { + const svalue *sval = iter.second; + if (const poisoned_svalue *psval + = sval->dyn_cast_poisoned_svalue ()) + if (psval->get_poison_kind () == POISON_KIND_UNINIT) + { + const binding_key *key = iter.first; + const concrete_binding *ckey + = key->dyn_cast_concrete_binding (); + gcc_assert (ckey); + result += ckey->get_size_in_bits (); + } + } + return result; + } + } + } + + void inform_number_of_uninit_bits (location_t loc) const + { + bit_size_t num_uninit_bits = calc_num_uninit_bits (); + if (num_uninit_bits <= 0) + return; + if (num_uninit_bits % BITS_PER_UNIT == 0) + { + /* Express in bytes. */ + byte_size_t num_uninit_bytes = num_uninit_bits / BITS_PER_UNIT; + if (num_uninit_bytes == 1) + inform (loc, "1 byte is uninitialized"); + else + inform (loc, + "%wu bytes are uninitialized", num_uninit_bytes.to_uhwi ()); + } + else + { + /* Express in bits. */ + if (num_uninit_bits == 1) + inform (loc, "1 bit is uninitialized"); + else + inform (loc, + "%wu bits are uninitialized", num_uninit_bits.to_uhwi ()); + } + } + + void complain_about_uninit_ranges (location_t loc) const + { + if (const compound_svalue *compound_sval + = m_copied_sval->dyn_cast_compound_svalue ()) + { + /* Find keys for uninit svals. */ + auto_vec<const concrete_binding *> uninit_keys; + for (auto iter : *compound_sval) + { + const svalue *sval = iter.second; + if (const poisoned_svalue *psval + = sval->dyn_cast_poisoned_svalue ()) + if (psval->get_poison_kind () == POISON_KIND_UNINIT) + { + const binding_key *key = iter.first; + const concrete_binding *ckey + = key->dyn_cast_concrete_binding (); + gcc_assert (ckey); + uninit_keys.safe_push (ckey); + } + } + /* Complain about them in sorted order. */ + uninit_keys.qsort (concrete_binding::cmp_ptr_ptr); + + std::unique_ptr<record_layout> layout; + + tree type = m_copied_sval->get_type (); + if (type && TREE_CODE (type) == RECORD_TYPE) + { + // (std::make_unique is C++14) + layout = std::unique_ptr<record_layout> (new record_layout (type)); + + if (0) + layout->dump (); + } + + unsigned i; + const concrete_binding *ckey; + FOR_EACH_VEC_ELT (uninit_keys, i, ckey) + { + bit_offset_t start_bit = ckey->get_start_bit_offset (); + bit_offset_t next_bit = ckey->get_next_bit_offset (); + complain_about_uninit_range (loc, start_bit, next_bit, + layout.get ()); + } + } + } + + void complain_about_uninit_range (location_t loc, + bit_offset_t start_bit, + bit_offset_t next_bit, + const record_layout *layout) const + { + if (layout) + { + while (start_bit < next_bit) + { + if (const record_layout::item *item + = layout->get_item_at (start_bit)) + { + gcc_assert (start_bit >= item->get_start_bit_offset ()); + gcc_assert (start_bit < item->get_next_bit_offset ()); + if (item->get_start_bit_offset () == start_bit + && item->get_next_bit_offset () <= next_bit) + complain_about_fully_uninit_item (*item); + else + complain_about_partially_uninit_item (*item); + start_bit = item->get_next_bit_offset (); + continue; + } + else + break; + } + } + + if (start_bit >= next_bit) + return; + + if (start_bit % 8 == 0 && next_bit % 8 == 0) + { + /* Express in bytes. */ + byte_offset_t start_byte = start_bit / 8; + byte_offset_t last_byte = (next_bit / 8) - 1; + if (last_byte == start_byte) + inform (loc, + "byte %wu is uninitialized", + start_byte.to_uhwi ()); + else + inform (loc, + "bytes %wu - %wu are uninitialized", + start_byte.to_uhwi (), + last_byte.to_uhwi ()); + } + else + { + /* Express in bits. */ + bit_offset_t last_bit = next_bit - 1; + if (last_bit == start_bit) + inform (loc, + "bit %wu is uninitialized", + start_bit.to_uhwi ()); + else + inform (loc, + "bits %wu - %wu are uninitialized", + start_bit.to_uhwi (), + last_bit.to_uhwi ()); + } + } + + static void + complain_about_fully_uninit_item (const record_layout::item &item) + { + tree field = item.m_field; + bit_size_t num_bits = item.m_bit_range.m_size_in_bits; + if (item.m_is_padding) + { + if (num_bits % 8 == 0) + { + /* Express in bytes. */ + byte_size_t num_bytes = num_bits / BITS_PER_UNIT; + if (num_bytes == 1) + inform (DECL_SOURCE_LOCATION (field), + "padding after field %qD is uninitialized (1 byte)", + field); + else + inform (DECL_SOURCE_LOCATION (field), + "padding after field %qD is uninitialized (%wu bytes)", + field, num_bytes.to_uhwi ()); + } + else + { + /* Express in bits. */ + if (num_bits == 1) + inform (DECL_SOURCE_LOCATION (field), + "padding after field %qD is uninitialized (1 bit)", + field); + else + inform (DECL_SOURCE_LOCATION (field), + "padding after field %qD is uninitialized (%wu bits)", + field, num_bits.to_uhwi ()); + } + } + else + { + if (num_bits % 8 == 0) + { + /* Express in bytes. */ + byte_size_t num_bytes = num_bits / BITS_PER_UNIT; + if (num_bytes == 1) + inform (DECL_SOURCE_LOCATION (field), + "field %qD is uninitialized (1 byte)", field); + else + inform (DECL_SOURCE_LOCATION (field), + "field %qD is uninitialized (%wu bytes)", + field, num_bytes.to_uhwi ()); + } + else + { + /* Express in bits. */ + if (num_bits == 1) + inform (DECL_SOURCE_LOCATION (field), + "field %qD is uninitialized (1 bit)", field); + else + inform (DECL_SOURCE_LOCATION (field), + "field %qD is uninitialized (%wu bits)", + field, num_bits.to_uhwi ()); + } + } + } + + static void + complain_about_partially_uninit_item (const record_layout::item &item) + { + tree field = item.m_field; + if (item.m_is_padding) + inform (DECL_SOURCE_LOCATION (field), + "padding after field %qD is partially uninitialized", + field); + else + inform (DECL_SOURCE_LOCATION (field), + "field %qD is partially uninitialized", + field); + /* TODO: ideally we'd describe what parts are uninitialized. */ + } + + void maybe_emit_fixit_hint () const + { + if (tree decl = m_src_region->maybe_get_decl ()) + { + gcc_rich_location hint_richloc (DECL_SOURCE_LOCATION (decl)); + hint_richloc.add_fixit_insert_after (" = {0}"); + inform (&hint_richloc, + "suggest forcing zero-initialization by" + " providing a %<{0}%> initializer"); + } + } + +private: + const region *m_src_region; + const region *m_dest_region; + const svalue *m_copied_sval; +}; + +/* Return true if any part of SVAL is uninitialized. */ + +static bool +contains_uninit_p (const svalue *sval) +{ + struct uninit_finder : public visitor + { + public: + uninit_finder () : m_found_uninit (false) {} + void visit_poisoned_svalue (const poisoned_svalue *sval) + { + if (sval->get_poison_kind () == POISON_KIND_UNINIT) + m_found_uninit = true; + } + bool m_found_uninit; + }; + + uninit_finder v; + sval->accept (&v); + + return v.m_found_uninit; +} + +/* Function for use by plugins when simulating writing data through a + pointer to an "untrusted" region DST_REG (and thus crossing a security + boundary), such as copying data to user space in an OS kernel. + + Check that COPIED_SVAL is fully initialized. If not, complain about + an infoleak to CTXT. + + SRC_REG can be NULL; if non-NULL it is used as a hint in the diagnostic + as to where COPIED_SVAL came from. */ + +void +region_model::maybe_complain_about_infoleak (const region *dst_reg, + const svalue *copied_sval, + const region *src_reg, + region_model_context *ctxt) +{ + /* Check for exposure. */ + if (contains_uninit_p (copied_sval)) + ctxt->warn (new exposure_through_uninit_copy (src_reg, + dst_reg, + copied_sval)); +} + /* class noop_region_model_context : public region_model_context. */ void @@ -5637,7 +6708,7 @@ test_struct () /* Verify get_offset for "c.x". */ { const region *c_x_reg = model.get_lvalue (c_x, NULL); - region_offset offset = c_x_reg->get_offset (); + region_offset offset = c_x_reg->get_offset (&mgr); ASSERT_EQ (offset.get_base_region (), model.get_lvalue (c, NULL)); ASSERT_EQ (offset.get_bit_offset (), 0); } @@ -5645,7 +6716,7 @@ test_struct () /* Verify get_offset for "c.y". */ { const region *c_y_reg = model.get_lvalue (c_y, NULL); - region_offset offset = c_y_reg->get_offset (); + region_offset offset = c_y_reg->get_offset (&mgr); ASSERT_EQ (offset.get_base_region (), model.get_lvalue (c, NULL)); ASSERT_EQ (offset.get_bit_offset (), INT_TYPE_SIZE); } @@ -7140,7 +8211,7 @@ test_var () /* Verify get_offset for "i". */ { - region_offset offset = i_reg->get_offset (); + region_offset offset = i_reg->get_offset (&mgr); ASSERT_EQ (offset.get_base_region (), i_reg); ASSERT_EQ (offset.get_bit_offset (), 0); } @@ -7189,7 +8260,7 @@ test_array_2 () /* Verify get_offset for "arr[0]". */ { const region *arr_0_reg = model.get_lvalue (arr_0, NULL); - region_offset offset = arr_0_reg->get_offset (); + region_offset offset = arr_0_reg->get_offset (&mgr); ASSERT_EQ (offset.get_base_region (), model.get_lvalue (arr, NULL)); ASSERT_EQ (offset.get_bit_offset (), 0); } @@ -7197,11 +8268,19 @@ test_array_2 () /* Verify get_offset for "arr[1]". */ { const region *arr_1_reg = model.get_lvalue (arr_1, NULL); - region_offset offset = arr_1_reg->get_offset (); + region_offset offset = arr_1_reg->get_offset (&mgr); ASSERT_EQ (offset.get_base_region (), model.get_lvalue (arr, NULL)); ASSERT_EQ (offset.get_bit_offset (), INT_TYPE_SIZE); } + /* Verify get_offset for "arr[i]". */ + { + const region *arr_i_reg = model.get_lvalue (arr_i, NULL); + region_offset offset = arr_i_reg->get_offset (&mgr); + ASSERT_EQ (offset.get_base_region (), model.get_lvalue (arr, NULL)); + ASSERT_EQ (offset.get_symbolic_byte_offset ()->get_kind (), SK_BINOP); + } + /* "arr[i] = i;" - this should remove the earlier bindings. */ model.set_value (arr_i, i, NULL); ASSERT_EQ (model.get_rvalue (arr_i, NULL), model.get_rvalue (i, NULL)); diff --git a/gcc/analyzer/region-model.h b/gcc/analyzer/region-model.h index a1f2165..e86720a 100644 --- a/gcc/analyzer/region-model.h +++ b/gcc/analyzer/region-model.h @@ -28,6 +28,7 @@ along with GCC; see the file COPYING3. If not see #include "analyzer/svalue.h" #include "analyzer/region.h" +#include "analyzer/known-function-manager.h" using namespace ana; @@ -347,6 +348,11 @@ public: store_manager *get_store_manager () { return &m_store_mgr; } bounded_ranges_manager *get_range_manager () const { return m_range_mgr; } + known_function_manager *get_known_function_manager () + { + return &m_known_fn_mgr; + } + /* Dynamically-allocated region instances. The number of these within the analysis can grow arbitrarily. They are still owned by the manager. */ @@ -504,6 +510,8 @@ private: bounded_ranges_manager *m_range_mgr; + known_function_manager m_known_fn_mgr; + /* "Dynamically-allocated" region instances. The number of these within the analysis can grow arbitrarily. They are still owned by the manager. */ @@ -521,8 +529,11 @@ public: call_details (const gcall *call, region_model *model, region_model_context *ctxt); + region_model *get_model () const { return m_model; } region_model_manager *get_manager () const; region_model_context *get_ctxt () const { return m_ctxt; } + logger *get_logger () const; + uncertainty_t *get_uncertainty () const; tree get_lhs_type () const { return m_lhs_type; } const region *get_lhs_region () const { return m_lhs_region; } @@ -645,6 +656,12 @@ class region_model void impl_call_va_arg (const call_details &cd); void impl_call_va_end (const call_details &cd); + const svalue *maybe_get_copy_bounds (const region *src_reg, + const svalue *num_bytes_sval); + void update_for_zero_return (const call_details &cd, + bool unmergeable); + void update_for_nonzero_return (const call_details &cd); + void handle_unrecognized_call (const gcall *call, region_model_context *ctxt); void get_reachable_svalues (svalue_set *out, @@ -717,6 +734,9 @@ class region_model const svalue *rhs) const; tristate compare_initial_and_pointer (const initial_svalue *init, const region_svalue *ptr) const; + tristate symbolic_greater_than (const binop_svalue *a, + const svalue *b) const; + tristate structural_equality (const svalue *a, const svalue *b) const; tristate eval_condition (tree lhs, enum tree_code op, tree rhs, @@ -796,11 +816,20 @@ class region_model const svalue *get_string_size (const svalue *sval) const; const svalue *get_string_size (const region *reg) const; + void maybe_complain_about_infoleak (const region *dst_reg, + const svalue *copied_sval, + const region *src_reg, + region_model_context *ctxt); + /* Implemented in sm-malloc.cc */ void on_realloc_with_move (const call_details &cd, const svalue *old_ptr_sval, const svalue *new_ptr_sval); + /* Implemented in sm-taint.cc. */ + void mark_as_tainted (const svalue *sval, + region_model_context *ctxt); + private: const region *get_lvalue_1 (path_var pv, region_model_context *ctxt) const; const svalue *get_rvalue_1 (path_var pv, region_model_context *ctxt) const; @@ -812,6 +841,8 @@ class region_model get_representative_path_var_1 (const region *reg, svalue_set *visited) const; + const known_function *get_known_function (tree fndecl) const; + bool add_constraint (const svalue *lhs, enum tree_code op, const svalue *rhs, @@ -874,6 +905,12 @@ class region_model region_model_context *ctxt) const; void check_region_size (const region *lhs_reg, const svalue *rhs_sval, region_model_context *ctxt) const; + void check_symbolic_bounds (const region *base_reg, + const svalue *sym_byte_offset, + const svalue *num_bytes_sval, + const svalue *capacity, + enum access_direction dir, + region_model_context *ctxt) const; void check_region_bounds (const region *reg, enum access_direction dir, region_model_context *ctxt) const; @@ -1315,6 +1352,10 @@ public: engine (const supergraph *sg = NULL, logger *logger = NULL); const supergraph *get_supergraph () { return m_sg; } region_model_manager *get_model_manager () { return &m_mgr; } + known_function_manager *get_known_function_manager () + { + return m_mgr.get_known_function_manager (); + } void log_stats (logger *logger) const; diff --git a/gcc/analyzer/region.cc b/gcc/analyzer/region.cc index 9c8279b..09646bf 100644 --- a/gcc/analyzer/region.cc +++ b/gcc/analyzer/region.cc @@ -290,10 +290,10 @@ region::maybe_get_decl () const first call and caching it internally). */ region_offset -region::get_offset () const +region::get_offset (region_model_manager *mgr) const { if(!m_cached_offset) - m_cached_offset = new region_offset (calc_offset ()); + m_cached_offset = new region_offset (calc_offset (mgr)); return *m_cached_offset; } @@ -491,10 +491,11 @@ region::get_subregions_for_binding (region_model_manager *mgr, or a symbolic offset. */ region_offset -region::calc_offset () const +region::calc_offset (region_model_manager *mgr) const { const region *iter_region = this; bit_offset_t accum_bit_offset = 0; + const svalue *accum_byte_sval = NULL; while (iter_region) { @@ -504,16 +505,36 @@ region::calc_offset () const case RK_ELEMENT: case RK_OFFSET: case RK_BIT_RANGE: - { - bit_offset_t rel_bit_offset; - if (!iter_region->get_relative_concrete_offset (&rel_bit_offset)) - return region_offset::make_symbolic - (iter_region->get_parent_region ()); - accum_bit_offset += rel_bit_offset; - iter_region = iter_region->get_parent_region (); - } + if (accum_byte_sval) + { + const svalue *sval + = iter_region->get_relative_symbolic_offset (mgr); + accum_byte_sval + = mgr->get_or_create_binop (sval->get_type (), PLUS_EXPR, + accum_byte_sval, sval); + iter_region = iter_region->get_parent_region (); + } + else + { + bit_offset_t rel_bit_offset; + if (iter_region->get_relative_concrete_offset (&rel_bit_offset)) + { + accum_bit_offset += rel_bit_offset; + iter_region = iter_region->get_parent_region (); + } + else + { + /* If the iter_region is not concrete anymore, convert the + accumulated bits to a svalue in bytes and revisit the + iter_region collecting the symbolic value. */ + byte_offset_t byte_offset = accum_bit_offset / BITS_PER_UNIT; + tree offset_tree = wide_int_to_tree (integer_type_node, + byte_offset); + accum_byte_sval + = mgr->get_or_create_constant_svalue (offset_tree); + } + } continue; - case RK_SIZED: iter_region = iter_region->get_parent_region (); continue; @@ -527,10 +548,18 @@ region::calc_offset () const continue; default: - return region_offset::make_concrete (iter_region, accum_bit_offset); + return accum_byte_sval + ? region_offset::make_symbolic (iter_region, + accum_byte_sval) + : region_offset::make_concrete (iter_region, + accum_bit_offset); } } - return region_offset::make_concrete (iter_region, accum_bit_offset); + + return accum_byte_sval ? region_offset::make_symbolic (iter_region, + accum_byte_sval) + : region_offset::make_concrete (iter_region, + accum_bit_offset); } /* Base implementation of region::get_relative_concrete_offset vfunc. */ @@ -541,6 +570,14 @@ region::get_relative_concrete_offset (bit_offset_t *) const return false; } +/* Base implementation of region::get_relative_symbolic_offset vfunc. */ + +const svalue * +region::get_relative_symbolic_offset (region_model_manager *mgr) const +{ + return mgr->get_or_create_unknown_svalue (integer_type_node); +} + /* Attempt to get the position and size of this region expressed as a concrete range of bytes relative to its parent. If successful, return true and write to *OUT. @@ -1316,6 +1353,25 @@ field_region::get_relative_concrete_offset (bit_offset_t *out) const return true; } + +/* Implementation of region::get_relative_symbolic_offset vfunc + for field_region. + If known, the returned svalue is equal to the offset converted to bytes and + rounded off. */ + +const svalue * +field_region::get_relative_symbolic_offset (region_model_manager *mgr) const +{ + bit_offset_t out; + if (get_relative_concrete_offset (&out)) + { + tree cst_tree + = wide_int_to_tree (integer_type_node, out / BITS_PER_UNIT); + return mgr->get_or_create_constant_svalue (cst_tree); + } + return mgr->get_or_create_unknown_svalue (integer_type_node); +} + /* class element_region : public region. */ /* Implementation of region::accept vfunc for element_region. */ @@ -1382,6 +1438,29 @@ element_region::get_relative_concrete_offset (bit_offset_t *out) const return false; } +/* Implementation of region::get_relative_symbolic_offset vfunc + for element_region. */ + +const svalue * +element_region::get_relative_symbolic_offset (region_model_manager *mgr) const +{ + tree elem_type = get_type (); + + /* First, use int_size_in_bytes, to reject the case where we + have an incomplete type, or a non-constant value. */ + HOST_WIDE_INT hwi_byte_size = int_size_in_bytes (elem_type); + if (hwi_byte_size > 0) + { + tree byte_size_tree = wide_int_to_tree (integer_type_node, + hwi_byte_size); + const svalue *byte_size_sval + = mgr->get_or_create_constant_svalue (byte_size_tree); + return mgr->get_or_create_binop (integer_type_node, MULT_EXPR, + m_index, byte_size_sval); + } + return mgr->get_or_create_unknown_svalue (integer_type_node); +} + /* class offset_region : public region. */ /* Implementation of region::accept vfunc for offset_region. */ @@ -1438,6 +1517,16 @@ offset_region::get_relative_concrete_offset (bit_offset_t *out) const return false; } +/* Implementation of region::get_relative_symbolic_offset vfunc + for offset_region. */ + +const svalue * +offset_region::get_relative_symbolic_offset (region_model_manager *mgr + ATTRIBUTE_UNUSED) const +{ + return get_byte_offset (); +} + /* Implementation of region::get_byte_size_sval vfunc for offset_region. */ const svalue * @@ -1683,6 +1772,20 @@ bit_range_region::get_relative_concrete_offset (bit_offset_t *out) const return true; } +/* Implementation of region::get_relative_symbolic_offset vfunc for + bit_range_region. + The returned svalue is equal to the offset converted to bytes and + rounded off. */ + +const svalue * +bit_range_region::get_relative_symbolic_offset (region_model_manager *mgr) + const +{ + byte_offset_t start_byte = m_bits.get_start_bit_offset () / BITS_PER_UNIT; + tree start_bit_tree = wide_int_to_tree (integer_type_node, start_byte); + return mgr->get_or_create_constant_svalue (start_bit_tree); +} + /* class var_arg_region : public region. */ void diff --git a/gcc/analyzer/region.h b/gcc/analyzer/region.h index 34ce1fa..6315fac 100644 --- a/gcc/analyzer/region.h +++ b/gcc/analyzer/region.h @@ -175,7 +175,7 @@ public: bool involves_p (const svalue *sval) const; - region_offset get_offset () const; + region_offset get_offset (region_model_manager *mgr) const; /* Attempt to get the size of this region as a concrete number of bytes. If successful, return true and write the size to *OUT. @@ -196,6 +196,11 @@ public: Otherwise return false. */ virtual bool get_relative_concrete_offset (bit_offset_t *out) const; + /* Get the offset in bytes of this region relative to its parent as a svalue. + Might return an unknown_svalue. */ + virtual const svalue * + get_relative_symbolic_offset (region_model_manager *mgr) const; + /* Attempt to get the position and size of this region expressed as a concrete range of bytes relative to its parent. If successful, return true and write to *OUT. @@ -226,7 +231,7 @@ public: region (complexity c, unsigned id, const region *parent, tree type); private: - region_offset calc_offset () const; + region_offset calc_offset (region_model_manager *mgr) const; complexity m_complexity; unsigned m_id; // purely for deterministic sorting at this stage, for dumps @@ -751,6 +756,8 @@ public: tree get_field () const { return m_field; } bool get_relative_concrete_offset (bit_offset_t *out) const final override; + const svalue *get_relative_symbolic_offset (region_model_manager *mgr) + const final override; private: tree m_field; @@ -835,6 +842,8 @@ public: virtual bool get_relative_concrete_offset (bit_offset_t *out) const final override; + const svalue *get_relative_symbolic_offset (region_model_manager *mgr) + const final override; private: const svalue *m_index; @@ -919,6 +928,8 @@ public: const svalue *get_byte_offset () const { return m_byte_offset; } bool get_relative_concrete_offset (bit_offset_t *out) const final override; + const svalue *get_relative_symbolic_offset (region_model_manager *mgr) + const final override; const svalue * get_byte_size_sval (region_model_manager *mgr) const final override; @@ -1245,6 +1256,8 @@ public: bool get_bit_size (bit_size_t *out) const final override; const svalue *get_byte_size_sval (region_model_manager *mgr) const final override; bool get_relative_concrete_offset (bit_offset_t *out) const final override; + const svalue *get_relative_symbolic_offset (region_model_manager *mgr) + const final override; private: bit_range m_bits; diff --git a/gcc/analyzer/sm-taint.cc b/gcc/analyzer/sm-taint.cc index 549373b..f5c0cc1 100644 --- a/gcc/analyzer/sm-taint.cc +++ b/gcc/analyzer/sm-taint.cc @@ -1365,6 +1365,33 @@ region_model::check_dynamic_size_for_taint (enum memory_space mem_space, } } +/* Mark SVAL as TAINTED. CTXT must be non-NULL. */ + +void +region_model::mark_as_tainted (const svalue *sval, + region_model_context *ctxt) +{ + gcc_assert (sval); + gcc_assert (ctxt); + + sm_state_map *smap; + const state_machine *sm; + unsigned sm_idx; + if (!ctxt->get_taint_map (&smap, &sm, &sm_idx)) + return; + + gcc_assert (smap); + gcc_assert (sm); + + const taint_state_machine &taint_sm = (const taint_state_machine &)*sm; + + const extrinsic_state *ext_state = ctxt->get_ext_state (); + if (!ext_state) + return; + + smap->set_state (this, sval, taint_sm.m_tainted, NULL, *ext_state); +} + } // namespace ana #endif /* #if ENABLE_ANALYZER */ diff --git a/gcc/analyzer/store.cc b/gcc/analyzer/store.cc index 848c5e1..1857d95 100644 --- a/gcc/analyzer/store.cc +++ b/gcc/analyzer/store.cc @@ -123,7 +123,7 @@ uncertainty_t::dump (bool simple) const const binding_key * binding_key::make (store_manager *mgr, const region *r) { - region_offset offset = r->get_offset (); + region_offset offset = r->get_offset (mgr->get_svalue_manager ()); if (offset.symbolic_p ()) return mgr->get_symbolic_binding (r); else @@ -380,7 +380,11 @@ bit_range::as_byte_range (byte_range *out) const void byte_range::dump_to_pp (pretty_printer *pp) const { - if (m_size_in_bytes == 1) + if (m_size_in_bytes == 0) + { + pp_string (pp, "empty"); + } + else if (m_size_in_bytes == 1) { pp_string (pp, "byte "); pp_wide_int (pp, m_start_byte_offset, SIGNED); @@ -455,7 +459,9 @@ bool byte_range::exceeds_p (const byte_range &other, byte_range *out_overhanging_byte_range) const { - if (other.get_last_byte_offset () < get_last_byte_offset ()) + gcc_assert (!empty_p ()); + + if (other.get_next_byte_offset () < get_next_byte_offset ()) { /* THIS definitely exceeds OTHER. */ byte_offset_t start = MAX (get_start_byte_offset (), @@ -477,6 +483,8 @@ bool byte_range::falls_short_of_p (byte_offset_t offset, byte_range *out_fall_short_bytes) const { + gcc_assert (!empty_p ()); + if (get_start_byte_offset () < offset) { /* THIS falls short of OFFSET. */ @@ -897,7 +905,7 @@ binding_map::apply_ctor_val_to_range (const region *parent_reg, = get_subregion_within_ctor (parent_reg, min_index, mgr); const region *max_element = get_subregion_within_ctor (parent_reg, max_index, mgr); - region_offset min_offset = min_element->get_offset (); + region_offset min_offset = min_element->get_offset (mgr); if (min_offset.symbolic_p ()) return false; bit_offset_t start_bit_offset = min_offset.get_bit_offset (); @@ -955,11 +963,11 @@ binding_map::apply_ctor_pair_to_child_region (const region *parent_reg, gcc_assert (sval_byte_size != -1); bit_size_t sval_bit_size = sval_byte_size * BITS_PER_UNIT; /* Get offset of child relative to base region. */ - region_offset child_base_offset = child_reg->get_offset (); + region_offset child_base_offset = child_reg->get_offset (mgr); if (child_base_offset.symbolic_p ()) return false; /* Convert to an offset relative to the parent region. */ - region_offset parent_base_offset = parent_reg->get_offset (); + region_offset parent_base_offset = parent_reg->get_offset (mgr); gcc_assert (!parent_base_offset.symbolic_p ()); bit_offset_t child_parent_offset = (child_base_offset.get_bit_offset () @@ -1365,7 +1373,8 @@ binding_cluster::bind_compound_sval (store_manager *mgr, const region *reg, const compound_svalue *compound_sval) { - region_offset reg_offset = reg->get_offset (); + region_offset reg_offset + = reg->get_offset (mgr->get_svalue_manager ()); if (reg_offset.symbolic_p ()) { m_touched = true; @@ -1614,7 +1623,7 @@ binding_cluster::get_any_binding (store_manager *mgr, /* Alternatively, if this is a symbolic read and the cluster has any bindings, then we don't know if we're reading those values or not, so the result is also "UNKNOWN". */ - if (reg->get_offset ().symbolic_p () + if (reg->get_offset (mgr->get_svalue_manager ()).symbolic_p () && m_map.elements () > 0) { region_model_manager *rmm_mgr = mgr->get_svalue_manager (); @@ -1643,10 +1652,11 @@ const svalue * binding_cluster::maybe_get_compound_binding (store_manager *mgr, const region *reg) const { - region_offset cluster_offset = m_base_region->get_offset (); + region_offset cluster_offset + = m_base_region->get_offset (mgr->get_svalue_manager ()); if (cluster_offset.symbolic_p ()) return NULL; - region_offset reg_offset = reg->get_offset (); + region_offset reg_offset = reg->get_offset (mgr->get_svalue_manager ()); if (reg_offset.symbolic_p ()) return NULL; diff --git a/gcc/analyzer/store.h b/gcc/analyzer/store.h index ac8b685..d172ee7 100644 --- a/gcc/analyzer/store.h +++ b/gcc/analyzer/store.h @@ -237,6 +237,11 @@ struct bit_range void dump_to_pp (pretty_printer *pp) const; void dump () const; + bool empty_p () const + { + return m_size_in_bits == 0; + } + bit_offset_t get_start_bit_offset () const { return m_start_bit_offset; @@ -247,6 +252,7 @@ struct bit_range } bit_offset_t get_last_bit_offset () const { + gcc_assert (!empty_p ()); return get_next_bit_offset () - 1; } @@ -297,6 +303,11 @@ struct byte_range void dump_to_pp (pretty_printer *pp) const; void dump () const; + bool empty_p () const + { + return m_size_in_bytes == 0; + } + bool contains_p (byte_offset_t offset) const { return (offset >= get_start_byte_offset () @@ -329,6 +340,7 @@ struct byte_range } byte_offset_t get_last_byte_offset () const { + gcc_assert (!empty_p ()); return m_start_byte_offset + m_size_in_bytes - 1; } diff --git a/gcc/c-family/ChangeLog b/gcc/c-family/ChangeLog index 3fcf73b..4144df5 100644 --- a/gcc/c-family/ChangeLog +++ b/gcc/c-family/ChangeLog @@ -1,3 +1,24 @@ +2022-09-09 Jan-Benedict Glaw <jbglaw@lug-owl.de> + + * c-format.cc (convert_format_name_to_system_name): Fix warning. + +2022-09-07 Joseph Myers <joseph@codesourcery.com> + + * c-common.cc (c_common_reswords): Use D_C2X instead of D_CXXONLY + for alignas, alignof, bool, false, static_assert, thread_local and + true. + +2022-09-07 Jakub Jelinek <jakub@redhat.com> + + * c.opt (Winvalid-utf8): Use ObjC instead of objC. Remove + " in comments" from description. + (Wunicode): New option. + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + PR c/106836 + * c-omp.cc (c_omp_split_clauses): Handle OMP_CLAUSE_DOACROSS. + 2022-09-03 Jakub Jelinek <jakub@redhat.com> * c-pragma.h (enum pragma_omp_clause): Add PRAGMA_OMP_CLAUSE_DOACROSS. diff --git a/gcc/c-family/c-common.cc b/gcc/c-family/c-common.cc index 9746504..0a5b7e1 100644 --- a/gcc/c-family/c-common.cc +++ b/gcc/c-family/c-common.cc @@ -459,11 +459,11 @@ const struct c_common_resword c_common_reswords[] = { "__GIMPLE", RID_GIMPLE, D_CONLY }, { "__PHI", RID_PHI, D_CONLY }, { "__RTL", RID_RTL, D_CONLY }, - { "alignas", RID_ALIGNAS, D_CXXONLY | D_CXX11 | D_CXXWARN }, - { "alignof", RID_ALIGNOF, D_CXXONLY | D_CXX11 | D_CXXWARN }, + { "alignas", RID_ALIGNAS, D_C2X | D_CXX11 | D_CXXWARN }, + { "alignof", RID_ALIGNOF, D_C2X | D_CXX11 | D_CXXWARN }, { "asm", RID_ASM, D_ASM }, { "auto", RID_AUTO, 0 }, - { "bool", RID_BOOL, D_CXXONLY | D_CXXWARN }, + { "bool", RID_BOOL, D_C2X | D_CXXWARN }, { "break", RID_BREAK, 0 }, { "case", RID_CASE, 0 }, { "catch", RID_CATCH, D_CXX_OBJC | D_CXXWARN }, @@ -489,7 +489,7 @@ const struct c_common_resword c_common_reswords[] = { "explicit", RID_EXPLICIT, D_CXXONLY | D_CXXWARN }, { "export", RID_EXPORT, D_CXXONLY | D_CXXWARN }, { "extern", RID_EXTERN, 0 }, - { "false", RID_FALSE, D_CXXONLY | D_CXXWARN }, + { "false", RID_FALSE, D_C2X | D_CXXWARN }, { "float", RID_FLOAT, 0 }, { "for", RID_FOR, 0 }, { "friend", RID_FRIEND, D_CXXONLY | D_CXXWARN }, @@ -515,15 +515,15 @@ const struct c_common_resword c_common_reswords[] = { "signed", RID_SIGNED, 0 }, { "sizeof", RID_SIZEOF, 0 }, { "static", RID_STATIC, 0 }, - { "static_assert", RID_STATIC_ASSERT, D_CXXONLY | D_CXX11 | D_CXXWARN }, + { "static_assert", RID_STATIC_ASSERT, D_C2X | D_CXX11 | D_CXXWARN }, { "static_cast", RID_STATCAST, D_CXXONLY | D_CXXWARN }, { "struct", RID_STRUCT, 0 }, { "switch", RID_SWITCH, 0 }, { "template", RID_TEMPLATE, D_CXXONLY | D_CXXWARN }, { "this", RID_THIS, D_CXXONLY | D_CXXWARN }, - { "thread_local", RID_THREAD, D_CXXONLY | D_CXX11 | D_CXXWARN }, + { "thread_local", RID_THREAD, D_C2X | D_CXX11 | D_CXXWARN }, { "throw", RID_THROW, D_CXX_OBJC | D_CXXWARN }, - { "true", RID_TRUE, D_CXXONLY | D_CXXWARN }, + { "true", RID_TRUE, D_C2X | D_CXXWARN }, { "try", RID_TRY, D_CXX_OBJC | D_CXXWARN }, { "typedef", RID_TYPEDEF, 0 }, { "typename", RID_TYPENAME, D_CXXONLY | D_CXXWARN }, diff --git a/gcc/c-family/c-format.cc b/gcc/c-family/c-format.cc index 68b94da..a6c380b 100644 --- a/gcc/c-family/c-format.cc +++ b/gcc/c-family/c-format.cc @@ -5111,8 +5111,7 @@ convert_format_name_to_system_name (const char *attr_name) #ifdef TARGET_OVERRIDES_FORMAT_ATTRIBUTES /* Check if format attribute is overridden by target. */ - if (TARGET_OVERRIDES_FORMAT_ATTRIBUTES != NULL - && TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT > 0) + if (TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT > 0) { for (i = 0; i < TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT; ++i) { diff --git a/gcc/c-family/c-omp.cc b/gcc/c-family/c-omp.cc index 56bc4b1..1b086d8 100644 --- a/gcc/c-family/c-omp.cc +++ b/gcc/c-family/c-omp.cc @@ -1877,6 +1877,12 @@ c_omp_split_clauses (location_t loc, enum tree_code code, case OMP_CLAUSE_DEPEND: s = C_OMP_CLAUSE_SPLIT_TARGET; break; + case OMP_CLAUSE_DOACROSS: + /* This can happen with invalid depend(source) or + depend(sink:vec) on target combined with other constructs. */ + gcc_assert (OMP_CLAUSE_DOACROSS_DEPEND (clauses)); + s = C_OMP_CLAUSE_SPLIT_TARGET; + break; case OMP_CLAUSE_NUM_TEAMS: s = C_OMP_CLAUSE_SPLIT_TEAMS; break; diff --git a/gcc/c-family/c.opt b/gcc/c-family/c.opt index 4515664..1c7f89e 100644 --- a/gcc/c-family/c.opt +++ b/gcc/c-family/c.opt @@ -822,8 +822,8 @@ C ObjC C++ ObjC++ CPP(warn_invalid_pch) CppReason(CPP_W_INVALID_PCH) Var(cpp_war Warn about PCH files that are found but not used. Winvalid-utf8 -C objC C++ ObjC++ CPP(cpp_warn_invalid_utf8) CppReason(CPP_W_INVALID_UTF8) Var(warn_invalid_utf8) Init(0) Warning -Warn about invalid UTF-8 characters in comments. +C ObjC C++ ObjC++ CPP(cpp_warn_invalid_utf8) CppReason(CPP_W_INVALID_UTF8) Var(warn_invalid_utf8) Init(0) Warning +Warn about invalid UTF-8 characters. Wjump-misses-init C ObjC Var(warn_jump_misses_init) Warning LangEnabledby(C ObjC,Wc++-compat) @@ -1345,6 +1345,10 @@ Wundef C ObjC C++ ObjC++ CPP(warn_undef) CppReason(CPP_W_UNDEF) Var(cpp_warn_undef) Init(0) Warning Warn if an undefined macro is used in an #if directive. +Wunicode +C ObjC C++ ObjC++ CPP(cpp_warn_unicode) CppReason(CPP_W_UNICODE) Var(warn_unicode) Init(1) Warning +Warn about invalid forms of delimited or named escape sequences. + Wuninitialized C ObjC C++ ObjC++ LTO LangEnabledBy(C ObjC C++ ObjC++ LTO,Wall) ; diff --git a/gcc/c/ChangeLog b/gcc/c/ChangeLog index a97faa6..41dc86b 100644 --- a/gcc/c/ChangeLog +++ b/gcc/c/ChangeLog @@ -1,3 +1,15 @@ +2022-09-07 Joseph Myers <joseph@codesourcery.com> + + * c-parser.cc (c_parser_static_assert_declaration_no_semi) + (c_parser_alignas_specifier, c_parser_alignof_expression): Allow + for C2x spellings of keywords. + (c_parser_postfix_expression): Handle RID_TRUE and RID_FALSE. + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + * c-parser.cc (c_parser_omp_clause_doacross_sink): Don't verify val + in omp_cur_iteration - 1 has integer_type_node type. + 2022-09-03 Jakub Jelinek <jakub@redhat.com> * c-parser.cc (c_parser_omp_clause_name): Handle doacross. diff --git a/gcc/c/c-parser.cc b/gcc/c/c-parser.cc index 65d73a6..d134448 100644 --- a/gcc/c/c-parser.cc +++ b/gcc/c/c-parser.cc @@ -2630,13 +2630,14 @@ c_parser_static_assert_declaration_no_semi (c_parser *parser) tree string = NULL_TREE; gcc_assert (c_parser_next_token_is_keyword (parser, RID_STATIC_ASSERT)); + tree spelling = c_parser_peek_token (parser)->value; assert_loc = c_parser_peek_token (parser)->location; if (flag_isoc99) pedwarn_c99 (assert_loc, OPT_Wpedantic, - "ISO C99 does not support %<_Static_assert%>"); + "ISO C99 does not support %qE", spelling); else pedwarn_c99 (assert_loc, OPT_Wpedantic, - "ISO C90 does not support %<_Static_assert%>"); + "ISO C90 does not support %qE", spelling); c_parser_consume_token (parser); matching_parens parens; if (!parens.require_open (parser)) @@ -2667,7 +2668,7 @@ c_parser_static_assert_declaration_no_semi (c_parser *parser) new C2X feature of _Static_assert. */ pedwarn_c11 (assert_loc, OPT_Wpedantic, "ISO C11 does not support omitting the string in " - "%<_Static_assert%>"); + "%qE", spelling); parens.require_close (parser); if (!INTEGRAL_TYPE_P (TREE_TYPE (value))) @@ -3774,13 +3775,14 @@ c_parser_alignas_specifier (c_parser * parser) tree ret = error_mark_node; location_t loc = c_parser_peek_token (parser)->location; gcc_assert (c_parser_next_token_is_keyword (parser, RID_ALIGNAS)); + tree spelling = c_parser_peek_token (parser)->value; c_parser_consume_token (parser); if (flag_isoc99) pedwarn_c99 (loc, OPT_Wpedantic, - "ISO C99 does not support %<_Alignas%>"); + "ISO C99 does not support %qE", spelling); else pedwarn_c99 (loc, OPT_Wpedantic, - "ISO C90 does not support %<_Alignas%>"); + "ISO C90 does not support %qE", spelling); matching_parens parens; if (!parens.require_open (parser)) return ret; @@ -8399,10 +8401,12 @@ c_parser_alignof_expression (c_parser *parser) location_t end_loc; tree alignof_spelling = c_parser_peek_token (parser)->value; gcc_assert (c_parser_next_token_is_keyword (parser, RID_ALIGNOF)); - bool is_c11_alignof = strcmp (IDENTIFIER_POINTER (alignof_spelling), - "_Alignof") == 0; + bool is_c11_alignof = (strcmp (IDENTIFIER_POINTER (alignof_spelling), + "_Alignof") == 0 + || strcmp (IDENTIFIER_POINTER (alignof_spelling), + "alignof") == 0); /* A diagnostic is not required for the use of this identifier in - the implementation namespace; only diagnose it for the C11 + the implementation namespace; only diagnose it for the C11 or C2X spelling because of existing code using the other spellings. */ if (is_c11_alignof) { @@ -10272,6 +10276,16 @@ c_parser_postfix_expression (c_parser *parser) pedwarn_c11 (loc, OPT_Wpedantic, "ISO C does not support %qs before C2X", "nullptr"); break; + case RID_TRUE: + c_parser_consume_token (parser); + expr.value = boolean_true_node; + set_c_expr_source_range (&expr, tok_range); + break; + case RID_FALSE: + c_parser_consume_token (parser); + expr.value = boolean_false_node; + set_c_expr_source_range (&expr, tok_range); + break; default: c_parser_error (parser, "expected expression"); expr.set_error (); @@ -15993,8 +16007,7 @@ c_parser_omp_clause_doacross_sink (c_parser *parser, location_t clause_loc, && c_parser_peek_nth_token (parser, 4)->type == CPP_CLOSE_PAREN) { tree val = c_parser_peek_nth_token (parser, 3)->value; - if (integer_onep (val) - && comptypes (TREE_TYPE (val), integer_type_node)) + if (integer_onep (val)) { c_parser_consume_token (parser); c_parser_consume_token (parser); diff --git a/gcc/collect2.cc b/gcc/collect2.cc index 9715e8e..d81c7f2 100644 --- a/gcc/collect2.cc +++ b/gcc/collect2.cc @@ -2784,6 +2784,13 @@ scan_prog_file (const char *prog_name, scanpass which_pass, if ((name = ldgetname (ldptr, &symbol)) == NULL) continue; /* Should never happen. */ +#ifdef XCOFF_DEBUGGING_INFO + /* All AIX function names have a duplicate entry + beginning with a dot. */ + if (*name == '.') + ++name; +#endif + switch (is_ctor_dtor (name)) { #if TARGET_AIX_VERSION diff --git a/gcc/common/config/riscv/riscv-common.cc b/gcc/common/config/riscv/riscv-common.cc index 120a038..7721916 100644 --- a/gcc/common/config/riscv/riscv-common.cc +++ b/gcc/common/config/riscv/riscv-common.cc @@ -1366,6 +1366,24 @@ riscv_expand_arch_from_cpu (int argc ATTRIBUTE_UNUSED, return xasprintf ("-march=%s", arch.c_str()); } +/* Report error if not found suitable multilib. */ +const char * +riscv_multi_lib_check (int argc ATTRIBUTE_UNUSED, + const char **argv ATTRIBUTE_UNUSED) +{ + if (riscv_no_matched_multi_lib) + fatal_error ( + input_location, + "Cannot find suitable multilib set for %<-march=%s%>/%<-mabi=%s%>", + riscv_current_arch_str.c_str (), + riscv_current_abi_str.c_str ()); + + return ""; +} + +/* We only override this in bare-metal toolchain. */ +#ifdef RISCV_USE_CUSTOMISED_MULTI_LIB + /* Find last switch with the prefix, options are take last one in general, return NULL if not found, and return the option value if found, it could return empty string if the option has no value. */ @@ -1440,21 +1458,6 @@ riscv_multi_lib_info_t::parse ( return true; } -/* Report error if not found suitable multilib. */ -const char * -riscv_multi_lib_check (int argc ATTRIBUTE_UNUSED, - const char **argv ATTRIBUTE_UNUSED) -{ - if (riscv_no_matched_multi_lib) - fatal_error ( - input_location, - "Can't find suitable multilib set for %<-march=%s%>/%<-mabi=%s%>", - riscv_current_arch_str.c_str (), - riscv_current_abi_str.c_str ()); - - return ""; -} - /* Checking ARG is not appeared in SWITCHES if NOT_ARG is set or ARG is appeared if NOT_ARG is not set. */ @@ -1534,9 +1537,6 @@ riscv_check_conds ( return match_score + ok_count * 100; } -/* We only override this in bare-metal toolchain. */ -#ifdef RISCV_USE_CUSTOMISED_MULTI_LIB - /* Implement TARGET_COMPUTE_MULTILIB. */ static const char * riscv_compute_multilib ( diff --git a/gcc/config.in b/gcc/config.in index 9c53319..6ac17be 100644 --- a/gcc/config.in +++ b/gcc/config.in @@ -2099,6 +2099,13 @@ #endif +/* Define if your assembler supports AIX debug frame section label reference. + */ +#ifndef USED_FOR_TARGET +#undef HAVE_XCOFF_DWARF_EXTRAS +#endif + + /* Define if you have a working <zstd.h> header file. */ #ifndef USED_FOR_TARGET #undef HAVE_ZSTD_H diff --git a/gcc/config/aarch64/aarch64.cc b/gcc/config/aarch64/aarch64.cc index 566763c..786ede7 100644 --- a/gcc/config/aarch64/aarch64.cc +++ b/gcc/config/aarch64/aarch64.cc @@ -19847,6 +19847,7 @@ aarch64_conditional_register_usage (void) { fixed_regs[i] = 1; call_used_regs[i] = 1; + CLEAR_HARD_REG_BIT (operand_reg_set, i); } } if (!TARGET_SVE) diff --git a/gcc/config/aarch64/aarch64.md b/gcc/config/aarch64/aarch64.md index 3ea16db..efcbecb 100644 --- a/gcc/config/aarch64/aarch64.md +++ b/gcc/config/aarch64/aarch64.md @@ -1195,7 +1195,7 @@ (define_insn "*mov<mode>_aarch64" [(set (match_operand:SHORT 0 "nonimmediate_operand" "=r,r, w,r ,r,w, m,m,r,w,w") - (match_operand:SHORT 1 "aarch64_mov_operand" " r,M,D<hq>,Usv,m,m,rZ,w,w,r,w"))] + (match_operand:SHORT 1 "aarch64_mov_operand" " r,M,D<hq>,Usv,m,m,rZ,w,w,rZ,w"))] "(register_operand (operands[0], <MODE>mode) || aarch64_reg_or_zero (operands[1], <MODE>mode))" { @@ -1219,11 +1219,11 @@ case 7: return "str\t%<size>1, %0"; case 8: - return "umov\t%w0, %1.<v>[0]"; + return TARGET_SIMD ? "umov\t%w0, %1.<v>[0]" : "fmov\t%w0, %s1"; case 9: - return "dup\t%0.<Vallxd>, %w1"; + return TARGET_SIMD ? "dup\t%0.<Vallxd>, %w1" : "fmov\t%s0, %w1"; case 10: - return "dup\t%<Vetype>0, %1.<v>[0]"; + return TARGET_SIMD ? "dup\t%<Vetype>0, %1.<v>[0]" : "fmov\t%s0, %s1"; default: gcc_unreachable (); } @@ -1231,7 +1231,7 @@ ;; The "mov_imm" type for CNT is just a placeholder. [(set_attr "type" "mov_reg,mov_imm,neon_move,mov_imm,load_4,load_4,store_4, store_4,neon_to_gp<q>,neon_from_gp<q>,neon_dup") - (set_attr "arch" "*,*,simd,sve,*,*,*,*,simd,simd,simd")] + (set_attr "arch" "*,*,simd,sve,*,*,*,*,*,*,*")] ) (define_expand "mov<mode>" @@ -1393,14 +1393,15 @@ (define_insn "*movti_aarch64" [(set (match_operand:TI 0 - "nonimmediate_operand" "= r,w,w, r,w,r,m,m,w,m") + "nonimmediate_operand" "= r,w,w,w, r,w,r,m,m,w,m") (match_operand:TI 1 - "aarch64_movti_operand" " rUti,Z,r, w,w,m,r,Z,m,w"))] + "aarch64_movti_operand" " rUti,Z,Z,r, w,w,m,r,Z,m,w"))] "(register_operand (operands[0], TImode) || aarch64_reg_or_zero (operands[1], TImode))" "@ # movi\\t%0.2d, #0 + fmov\t%d0, xzr # # mov\\t%0.16b, %1.16b @@ -1409,11 +1410,11 @@ stp\\txzr, xzr, %0 ldr\\t%q0, %1 str\\t%q1, %0" - [(set_attr "type" "multiple,neon_move,f_mcr,f_mrc,neon_logic_q, \ + [(set_attr "type" "multiple,neon_move,f_mcr,f_mcr,f_mrc,neon_logic_q, \ load_16,store_16,store_16,\ load_16,store_16") - (set_attr "length" "8,4,8,8,4,4,4,4,4,4") - (set_attr "arch" "*,simd,*,*,simd,*,*,*,fp,fp")] + (set_attr "length" "8,4,4,8,8,4,4,4,4,4,4") + (set_attr "arch" "*,simd,*,*,*,simd,*,*,*,fp,fp")] ) ;; Split a TImode register-register or register-immediate move into @@ -1452,16 +1453,19 @@ ) (define_insn "*mov<mode>_aarch64" - [(set (match_operand:HFBF 0 "nonimmediate_operand" "=w,w , w,?r,w,w ,w ,w,m,r,m ,r") - (match_operand:HFBF 1 "general_operand" "Y ,?rY,?r, w,w,Ufc,Uvi,m,w,m,rY,r"))] + [(set (match_operand:HFBF 0 "nonimmediate_operand" "=w,w ,w ,w ,?r,?r,w,w,w ,w ,w,m,r,m ,r") + (match_operand:HFBF 1 "general_operand" "Y ,?rY,?r,?rY, w, w,w,w,Ufc,Uvi,m,w,m,rY,r"))] "TARGET_FLOAT && (register_operand (operands[0], <MODE>mode) || aarch64_reg_or_fp_zero (operands[1], <MODE>mode))" "@ movi\\t%0.4h, #0 fmov\\t%h0, %w1 dup\\t%w0.4h, %w1 + fmov\\t%s0, %w1 umov\\t%w0, %1.h[0] + fmov\\t%w0, %s1 mov\\t%0.h[0], %1.h[0] + fmov\\t%s0, %s1 fmov\\t%h0, %1 * return aarch64_output_scalar_simd_mov_immediate (operands[1], HImode); ldr\\t%h0, %1 @@ -1469,9 +1473,10 @@ ldrh\\t%w0, %1 strh\\t%w1, %0 mov\\t%w0, %w1" - [(set_attr "type" "neon_move,f_mcr,neon_move,neon_to_gp, neon_move,fconsts, \ - neon_move,f_loads,f_stores,load_4,store_4,mov_reg") - (set_attr "arch" "simd,fp16,simd,simd,simd,fp16,simd,*,*,*,*,*")] + [(set_attr "type" "neon_move,f_mcr,neon_move,f_mcr,neon_to_gp,f_mrc, + neon_move,fmov,fconsts,neon_move,f_loads,f_stores, + load_4,store_4,mov_reg") + (set_attr "arch" "simd,fp16,simd,*,simd,*,simd,*,fp16,simd,*,*,*,*,*")] ) (define_insn "*mov<mode>_aarch64" @@ -1524,10 +1529,11 @@ (define_split [(set (match_operand:GPF_HF 0 "nonimmediate_operand") - (match_operand:GPF_HF 1 "general_operand"))] + (match_operand:GPF_HF 1 "const_double_operand"))] "can_create_pseudo_p () && !aarch64_can_const_movi_rtx_p (operands[1], <MODE>mode) && !aarch64_float_const_representable_p (operands[1]) + && !aarch64_float_const_zero_rtx_p (operands[1]) && aarch64_float_const_rtx_p (operands[1])" [(const_int 0)] { diff --git a/gcc/config/arm/mve.md b/gcc/config/arm/mve.md index c4dec01..7141786 100644 --- a/gcc/config/arm/mve.md +++ b/gcc/config/arm/mve.md @@ -1624,7 +1624,7 @@ [ (set (match_operand:MVE_2 0 "s_register_operand" "=w") (unspec:MVE_2 [(match_operand:MVE_2 1 "s_register_operand" "w") - (match_operand:SI 2 "mve_imm_7" "Ra")] + (match_operand:SI 2 "<MVE_pred>" "<MVE_constraint>")] VQSHLUQ_N_S)) ] "TARGET_HAVE_MVE" @@ -2615,7 +2615,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb")] + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>")] VQRSHRNBQ_N)) ] "TARGET_HAVE_MVE" @@ -2630,7 +2630,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb")] + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>")] VQRSHRUNBQ_N_S)) ] "TARGET_HAVE_MVE" @@ -3570,7 +3570,7 @@ (set (match_operand:MVE_2 0 "s_register_operand" "=w") (unspec:MVE_2 [(match_operand:MVE_2 1 "s_register_operand" "0") (match_operand:MVE_2 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_selective_upto_8" "Rg")] + (match_operand:SI 3 "<MVE_pred2>" "<MVE_constraint2>")] VSRIQ_N)) ] "TARGET_HAVE_MVE" @@ -4473,7 +4473,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb")] + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>")] VQRSHRNTQ_N)) ] "TARGET_HAVE_MVE" @@ -4489,7 +4489,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb")] + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>")] VQRSHRUNTQ_N_S)) ] "TARGET_HAVE_MVE" @@ -4777,7 +4777,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb")] + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>")] VRSHRNBQ_N)) ] "TARGET_HAVE_MVE" @@ -4793,7 +4793,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb")] + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>")] VRSHRNTQ_N)) ] "TARGET_HAVE_MVE" @@ -4987,7 +4987,7 @@ (set (match_operand:MVE_2 0 "s_register_operand" "=w") (unspec:MVE_2 [(match_operand:MVE_2 1 "s_register_operand" "0") (match_operand:MVE_2 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_7" "Ra") + (match_operand:SI 3 "<MVE_pred>" "<MVE_constraint>") (match_operand:<MVE_VPRED> 4 "vpr_register_operand" "Up")] VQSHLUQ_M_N_S)) ] @@ -5019,7 +5019,7 @@ (set (match_operand:MVE_2 0 "s_register_operand" "=w") (unspec:MVE_2 [(match_operand:MVE_2 1 "s_register_operand" "0") (match_operand:MVE_2 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_selective_upto_8" "Rg") + (match_operand:SI 3 "<MVE_pred2>" "<MVE_constraint2>") (match_operand:<MVE_VPRED> 4 "vpr_register_operand" "Up")] VSRIQ_M_N)) ] @@ -6138,7 +6138,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb") + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>") (match_operand:<MVE_VPRED> 4 "vpr_register_operand" "Up")] VQRSHRNBQ_M_N)) ] @@ -6155,7 +6155,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb") + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>") (match_operand:<MVE_VPRED> 4 "vpr_register_operand" "Up")] VQRSHRNTQ_M_N)) ] @@ -6223,7 +6223,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb") + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>") (match_operand:<MVE_VPRED> 4 "vpr_register_operand" "Up")] VRSHRNBQ_M_N)) ] @@ -6240,7 +6240,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb") + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>") (match_operand:<MVE_VPRED> 4 "vpr_register_operand" "Up")] VRSHRNTQ_M_N)) ] @@ -6461,7 +6461,7 @@ (set (match_operand:<V_narrow_pack> 0 "s_register_operand" "=w") (unspec:<V_narrow_pack> [(match_operand:<V_narrow_pack> 1 "s_register_operand" "0") (match_operand:MVE_5 2 "s_register_operand" "w") - (match_operand:SI 3 "mve_imm_8" "Rb") + (match_operand:SI 3 "<MVE_pred3>" "<MVE_constraint3>") (match_operand:<MVE_VPRED> 4 "vpr_register_operand" "Up")] VQRSHRUNBQ_M_N_S)) ] diff --git a/gcc/config/bpf/bpf.cc b/gcc/config/bpf/bpf.cc index 9cb56cf..5105565 100644 --- a/gcc/config/bpf/bpf.cc +++ b/gcc/config/bpf/bpf.cc @@ -428,7 +428,6 @@ bpf_compute_frame_layout (void) void bpf_expand_prologue (void) { - rtx insn; HOST_WIDE_INT size; size = (cfun->machine->local_vars_size @@ -468,7 +467,7 @@ bpf_expand_prologue (void) plus_constant (DImode, hard_frame_pointer_rtx, fp_offset - 8)); - insn = emit_move_insn (mem, gen_rtx_REG (DImode, regno)); + emit_move_insn (mem, gen_rtx_REG (DImode, regno)); fp_offset -= 8; } } @@ -481,15 +480,15 @@ bpf_expand_prologue (void) accessor. */ if (cfun->calls_alloca) { - insn = emit_move_insn (stack_pointer_rtx, - hard_frame_pointer_rtx); + emit_move_insn (stack_pointer_rtx, + hard_frame_pointer_rtx); if (size > 0) { - insn = emit_insn (gen_rtx_SET (stack_pointer_rtx, - gen_rtx_PLUS (Pmode, - stack_pointer_rtx, - GEN_INT (-size)))); + emit_insn (gen_rtx_SET (stack_pointer_rtx, + gen_rtx_PLUS (Pmode, + stack_pointer_rtx, + GEN_INT (-size)))); } } } @@ -504,7 +503,6 @@ bpf_expand_epilogue (void) not restoring callee-saved registers in BPF. */ if (TARGET_XBPF) { - rtx insn; int regno; int fp_offset = -cfun->machine->local_vars_size; @@ -528,7 +526,7 @@ bpf_expand_epilogue (void) plus_constant (DImode, hard_frame_pointer_rtx, fp_offset - 8)); - insn = emit_move_insn (gen_rtx_REG (DImode, regno), mem); + emit_move_insn (gen_rtx_REG (DImode, regno), mem); fp_offset -= 8; } } diff --git a/gcc/config/bpf/bpf.h b/gcc/config/bpf/bpf.h index 5b3f4a5..5790347 100644 --- a/gcc/config/bpf/bpf.h +++ b/gcc/config/bpf/bpf.h @@ -209,7 +209,7 @@ enum reg_class register REGNO. In general there is more that one such class; choose a class which is "minimal", meaning that no smaller class also contains the register. */ -#define REGNO_REG_CLASS(REGNO) GENERAL_REGS +#define REGNO_REG_CLASS(REGNO) ((void)(REGNO), GENERAL_REGS) /* A macro whose definition is the name of the class to which a valid base register must belong. A base register is one used in diff --git a/gcc/config/csky/csky.cc b/gcc/config/csky/csky.cc index a7dc6ce..4dc74d8 100644 --- a/gcc/config/csky/csky.cc +++ b/gcc/config/csky/csky.cc @@ -6342,9 +6342,7 @@ csky_emit_compare_float (enum rtx_code code, rtx op0, rtx op1) case GT: case LT: case LE: - if (op1 == CONST0_RTX (mode) && (CSKY_ISA_FEATURE_GET(fpv2_sf) - || CSKY_ISA_FEATURE_GET(fpv2_df) - || CSKY_ISA_FEATURE_GET(fpv2_divd))) + if (op1 == CONST0_RTX (mode) && TARGET_SUPPORT_FPV2) op1 = force_reg (mode, op1); break; case ORDERED: diff --git a/gcc/config/csky/csky.h b/gcc/config/csky/csky.h index 37410f0..f786ad5 100644 --- a/gcc/config/csky/csky.h +++ b/gcc/config/csky/csky.h @@ -165,6 +165,10 @@ || CSKY_ISA_FEATURE (fpv3_sf) \ || CSKY_ISA_FEATURE (fpv3_df)) +#define TARGET_SUPPORT_FPV2 (CSKY_ISA_FEATURE(fpv2_sf) \ + || CSKY_ISA_FEATURE(fpv2_df) \ + || CSKY_ISA_FEATURE(fpv2_divd)) + /* Number of loads/stores handled by ldm/stm. */ #define CSKY_MIN_MULTIPLE_STLD 3 #define CSKY_MAX_MULTIPLE_STLD 12 diff --git a/gcc/config/csky/csky.md b/gcc/config/csky/csky.md index 6b05930..6a65929 100644 --- a/gcc/config/csky/csky.md +++ b/gcc/config/csky/csky.md @@ -1279,7 +1279,8 @@ "reload_completed && !rtx_equal_p (operands[0], operands[1])" [(set (match_dup 0) (if_then_else:SI (ne (reg:CC CSKY_CC_REGNUM) (const_int 0)) - (plus:SI (match_dup 0) (match_dup 2))))] + (plus:SI (match_dup 0) (match_dup 2)) + (match_dup 0)))] { emit_insn (gen_movf (copy_rtx (operands[0]), copy_rtx (operands[1]), @@ -1305,7 +1306,8 @@ "reload_completed && !rtx_equal_p (operands[0], operands[1])" [(set (match_dup 0) (if_then_else:SI (eq (reg:CC CSKY_CC_REGNUM) (const_int 0)) - (plus:SI (match_dup 0) (match_dup 2))))] + (plus:SI (match_dup 0) (match_dup 2)) + (match_dup 0)))] { emit_insn (gen_movt (copy_rtx (operands[0]), copy_rtx (operands[1]), diff --git a/gcc/config/darwin-d.cc b/gcc/config/darwin-d.cc index e983883..2ceebc4 100644 --- a/gcc/config/darwin-d.cc +++ b/gcc/config/darwin-d.cc @@ -18,6 +18,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "tm.h" #include "tm_d.h" #include "d/d-target.h" #include "d/d-target-def.h" diff --git a/gcc/config/dragonfly-d.cc b/gcc/config/dragonfly-d.cc index d431638..881c5e6 100644 --- a/gcc/config/dragonfly-d.cc +++ b/gcc/config/dragonfly-d.cc @@ -18,6 +18,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "tm.h" #include "tm_d.h" #include "d/d-target.h" #include "d/d-target-def.h" diff --git a/gcc/config/freebsd-d.cc b/gcc/config/freebsd-d.cc index 189e4a6..c795ca2 100644 --- a/gcc/config/freebsd-d.cc +++ b/gcc/config/freebsd-d.cc @@ -18,7 +18,6 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "memmodel.h" #include "tm.h" #include "tm_d.h" #include "d/d-target.h" diff --git a/gcc/config/gcn/gcn-builtins.def b/gcc/config/gcn/gcn-builtins.def index 54e4ea4..2769190 100644 --- a/gcc/config/gcn/gcn-builtins.def +++ b/gcc/config/gcn/gcn-builtins.def @@ -59,6 +59,41 @@ DEF_BUILTIN (SQRTF, 3 /*CODE_FOR_sqrtf */, _A2 (GCN_BTI_SF, GCN_BTI_SF), gcn_expand_builtin_1) +DEF_BUILTIN (FABSVF, 3 /*CODE_FOR_fabsvf */, + "fabsvf", B_INSN, + _A2 (GCN_BTI_V64SF, GCN_BTI_V64SF), + gcn_expand_builtin_1) + +DEF_BUILTIN (LDEXPVF, 3 /*CODE_FOR_ldexpvf */, + "ldexpvf", B_INSN, + _A3 (GCN_BTI_V64SF, GCN_BTI_V64SF, GCN_BTI_V64SI), + gcn_expand_builtin_1) + +DEF_BUILTIN (LDEXPV, 3 /*CODE_FOR_ldexpv */, + "ldexpv", B_INSN, + _A3 (GCN_BTI_V64DF, GCN_BTI_V64DF, GCN_BTI_V64SI), + gcn_expand_builtin_1) + +DEF_BUILTIN (FREXPVF_EXP, 3 /*CODE_FOR_frexpvf_exp */, + "frexpvf_exp", B_INSN, + _A2 (GCN_BTI_V64SI, GCN_BTI_V64SF), + gcn_expand_builtin_1) + +DEF_BUILTIN (FREXPVF_MANT, 3 /*CODE_FOR_frexpvf_mant */, + "frexpvf_mant", B_INSN, + _A2 (GCN_BTI_V64SF, GCN_BTI_V64SF), + gcn_expand_builtin_1) + +DEF_BUILTIN (FREXPV_EXP, 3 /*CODE_FOR_frexpv_exp */, + "frexpv_exp", B_INSN, + _A2 (GCN_BTI_V64SI, GCN_BTI_V64DF), + gcn_expand_builtin_1) + +DEF_BUILTIN (FREXPV_MANT, 3 /*CODE_FOR_frexpv_mant */, + "frexpv_mant", B_INSN, + _A2 (GCN_BTI_V64DF, GCN_BTI_V64DF), + gcn_expand_builtin_1) + DEF_BUILTIN (CMP_SWAP, -1, "cmp_swap", B_INSN, _A4 (GCN_BTI_UINT, GCN_BTI_VOIDPTR, GCN_BTI_UINT, GCN_BTI_UINT), diff --git a/gcc/config/gcn/gcn-protos.h b/gcc/config/gcn/gcn-protos.h index 38197b9..ca80460 100644 --- a/gcc/config/gcn/gcn-protos.h +++ b/gcc/config/gcn/gcn-protos.h @@ -54,6 +54,7 @@ extern int gcn_hard_regno_nregs (int regno, machine_mode mode); extern void gcn_hsa_declare_function_name (FILE *file, const char *name, tree decl); extern HOST_WIDE_INT gcn_initial_elimination_offset (int, int); +extern REAL_VALUE_TYPE gcn_dconst1over2pi (void); extern bool gcn_inline_constant64_p (rtx, bool); extern bool gcn_inline_constant_p (rtx); extern int gcn_inline_fp_constant_p (rtx, bool); diff --git a/gcc/config/gcn/gcn-valu.md b/gcc/config/gcn/gcn-valu.md index 8c33ae0..3bfdf82 100644 --- a/gcc/config/gcn/gcn-valu.md +++ b/gcc/config/gcn/gcn-valu.md @@ -2290,6 +2290,187 @@ [(set_attr "type" "vop1") (set_attr "length" "8")]) +; These FP unops have f64, f32 and f16 versions. +(define_int_iterator MATH_UNOP_1OR2REG + [UNSPEC_FLOOR UNSPEC_CEIL]) + +; These FP unops only have f16/f32 versions. +(define_int_iterator MATH_UNOP_1REG + [UNSPEC_EXP2 UNSPEC_LOG2]) + +(define_int_iterator MATH_UNOP_TRIG + [UNSPEC_SIN UNSPEC_COS]) + +(define_int_attr math_unop + [(UNSPEC_FLOOR "floor") + (UNSPEC_CEIL "ceil") + (UNSPEC_EXP2 "exp2") + (UNSPEC_LOG2 "log2") + (UNSPEC_SIN "sin") + (UNSPEC_COS "cos")]) + +(define_insn "<math_unop><mode>2" + [(set (match_operand:FP 0 "register_operand" "= v") + (unspec:FP + [(match_operand:FP 1 "gcn_alu_operand" "vSvB")] + MATH_UNOP_1OR2REG))] + "" + "v_<math_unop>%i0\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "<math_unop><mode>2<exec>" + [(set (match_operand:V_FP 0 "register_operand" "= v") + (unspec:V_FP + [(match_operand:V_FP 1 "gcn_alu_operand" "vSvB")] + MATH_UNOP_1OR2REG))] + "" + "v_<math_unop>%i0\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "<math_unop><mode>2" + [(set (match_operand:FP_1REG 0 "register_operand" "= v") + (unspec:FP_1REG + [(match_operand:FP_1REG 1 "gcn_alu_operand" "vSvB")] + MATH_UNOP_1REG))] + "flag_unsafe_math_optimizations" + "v_<math_unop>%i0\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "<math_unop><mode>2<exec>" + [(set (match_operand:V_FP_1REG 0 "register_operand" "= v") + (unspec:V_FP_1REG + [(match_operand:V_FP_1REG 1 "gcn_alu_operand" "vSvB")] + MATH_UNOP_1REG))] + "flag_unsafe_math_optimizations" + "v_<math_unop>%i0\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "*<math_unop><mode>2_insn" + [(set (match_operand:FP_1REG 0 "register_operand" "= v") + (unspec:FP_1REG + [(match_operand:FP_1REG 1 "gcn_alu_operand" "vSvB")] + MATH_UNOP_TRIG))] + "flag_unsafe_math_optimizations" + "v_<math_unop>%i0\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "*<math_unop><mode>2<exec>_insn" + [(set (match_operand:V_FP_1REG 0 "register_operand" "= v") + (unspec:V_FP_1REG + [(match_operand:V_FP_1REG 1 "gcn_alu_operand" "vSvB")] + MATH_UNOP_TRIG))] + "flag_unsafe_math_optimizations" + "v_<math_unop>%i0\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +; Trigonometric functions need their input scaled by 1/(2*PI) first. + +(define_expand "<math_unop><mode>2" + [(set (match_dup 2) + (mult:FP_1REG + (match_dup 3) + (match_operand:FP_1REG 1 "gcn_alu_operand"))) + (set (match_operand:FP_1REG 0 "register_operand") + (unspec:FP_1REG + [(match_dup 2)] + MATH_UNOP_TRIG))] + "flag_unsafe_math_optimizations" + { + operands[2] = gen_reg_rtx (<MODE>mode); + operands[3] = const_double_from_real_value (gcn_dconst1over2pi (), + <MODE>mode); + }) + +(define_expand "<math_unop><mode>2<exec>" + [(set (match_dup 2) + (mult:V_FP_1REG + (match_dup 3) + (match_operand:V_FP_1REG 1 "gcn_alu_operand"))) + (set (match_operand:V_FP_1REG 0 "register_operand") + (unspec:V_FP_1REG + [(match_dup 2)] + MATH_UNOP_TRIG))] + "flag_unsafe_math_optimizations" + { + operands[2] = gen_reg_rtx (<MODE>mode); + operands[3] = + gcn_vec_constant (<MODE>mode, + const_double_from_real_value (gcn_dconst1over2pi (), + <SCALAR_MODE>mode)); + }) + +; Implement ldexp pattern + +(define_insn "ldexp<mode>3" + [(set (match_operand:FP 0 "register_operand" "=v") + (unspec:FP + [(match_operand:FP 1 "gcn_alu_operand" "vB") + (match_operand:SI 2 "gcn_alu_operand" "vSvA")] + UNSPEC_LDEXP))] + "" + "v_ldexp%i0\t%0, %1, %2" + [(set_attr "type" "vop3a") + (set_attr "length" "8")]) + +(define_insn "ldexp<mode>3<exec>" + [(set (match_operand:V_FP 0 "register_operand" "=v") + (unspec:V_FP + [(match_operand:V_FP 1 "gcn_alu_operand" "vB") + (match_operand:V64SI 2 "gcn_alu_operand" "vSvA")] + UNSPEC_LDEXP))] + "" + "v_ldexp%i0\t%0, %1, %2" + [(set_attr "type" "vop3a") + (set_attr "length" "8")]) + +; Implement frexp patterns + +(define_insn "frexp<mode>_exp2" + [(set (match_operand:SI 0 "register_operand" "=v") + (unspec:SI + [(match_operand:FP 1 "gcn_alu_operand" "vB")] + UNSPEC_FREXP_EXP))] + "" + "v_frexp_exp_i32%i1\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "frexp<mode>_mant2" + [(set (match_operand:FP 0 "register_operand" "=v") + (unspec:FP + [(match_operand:FP 1 "gcn_alu_operand" "vB")] + UNSPEC_FREXP_MANT))] + "" + "v_frexp_mant%i1\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "frexp<mode>_exp2<exec>" + [(set (match_operand:V64SI 0 "register_operand" "=v") + (unspec:V64SI + [(match_operand:V_FP 1 "gcn_alu_operand" "vB")] + UNSPEC_FREXP_EXP))] + "" + "v_frexp_exp_i32%i1\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + +(define_insn "frexp<mode>_mant2<exec>" + [(set (match_operand:V_FP 0 "register_operand" "=v") + (unspec:V_FP + [(match_operand:V_FP 1 "gcn_alu_operand" "vB")] + UNSPEC_FREXP_MANT))] + "" + "v_frexp_mant%i1\t%0, %1" + [(set_attr "type" "vop1") + (set_attr "length" "8")]) + ;; }}} ;; {{{ FP fused multiply and add diff --git a/gcc/config/gcn/gcn.cc b/gcc/config/gcn/gcn.cc index 8266755..eb822e2 100644 --- a/gcc/config/gcn/gcn.cc +++ b/gcc/config/gcn/gcn.cc @@ -779,12 +779,20 @@ init_ext_gcn_constants (void) /* FIXME: this constant probably does not match what hardware really loads. Reality check it eventually. */ real_from_string (&dconst1over2pi, - "0.1591549430918953357663423455968866839"); + "0.15915494309189532"); real_convert (&dconst1over2pi, SFmode, &dconst1over2pi); ext_gcn_constants_init = 1; } +REAL_VALUE_TYPE +gcn_dconst1over2pi (void) +{ + if (!ext_gcn_constants_init) + init_ext_gcn_constants (); + return dconst1over2pi; +} + /* Return non-zero if X is a constant that can appear as an inline operand. This is 0, 0.5, -0.5, 1, -1, 2, -2, 4,-4, 1/(2*pi) Or a vector of those. @@ -3605,6 +3613,7 @@ enum gcn_builtin_type_index GCN_BTI_SF, GCN_BTI_V64SI, GCN_BTI_V64SF, + GCN_BTI_V64DF, GCN_BTI_V64PTR, GCN_BTI_SIPTR, GCN_BTI_SFPTR, @@ -3621,6 +3630,7 @@ static GTY(()) tree gcn_builtin_types[GCN_BTI_MAX]; #define sf_type_node (gcn_builtin_types[GCN_BTI_SF]) #define v64si_type_node (gcn_builtin_types[GCN_BTI_V64SI]) #define v64sf_type_node (gcn_builtin_types[GCN_BTI_V64SF]) +#define v64df_type_node (gcn_builtin_types[GCN_BTI_V64DF]) #define v64ptr_type_node (gcn_builtin_types[GCN_BTI_V64PTR]) #define siptr_type_node (gcn_builtin_types[GCN_BTI_SIPTR]) #define sfptr_type_node (gcn_builtin_types[GCN_BTI_SFPTR]) @@ -3710,6 +3720,7 @@ gcn_init_builtin_types (void) sf_type_node = float32_type_node; v64si_type_node = build_vector_type (intSI_type_node, 64); v64sf_type_node = build_vector_type (float_type_node, 64); + v64df_type_node = build_vector_type (double_type_node, 64); v64ptr_type_node = build_vector_type (unsigned_intDI_type_node /*build_pointer_type (integer_type_node) */ @@ -3977,6 +3988,105 @@ gcn_expand_builtin_1 (tree exp, rtx target, rtx /*subtarget */ , emit_insn (gen_sqrtsf2 (target, arg)); return target; } + case GCN_BUILTIN_FABSVF: + { + if (ignore) + return target; + rtx exec = gcn_full_exec_reg (); + rtx arg = force_reg (V64SFmode, + expand_expr (CALL_EXPR_ARG (exp, 0), NULL_RTX, + V64SFmode, + EXPAND_NORMAL)); + emit_insn (gen_absv64sf2_exec + (target, arg, gcn_gen_undef (V64SFmode), exec)); + return target; + } + case GCN_BUILTIN_LDEXPVF: + { + if (ignore) + return target; + rtx exec = gcn_full_exec_reg (); + rtx arg1 = force_reg (V64SFmode, + expand_expr (CALL_EXPR_ARG (exp, 0), NULL_RTX, + V64SFmode, + EXPAND_NORMAL)); + rtx arg2 = force_reg (V64SImode, + expand_expr (CALL_EXPR_ARG (exp, 1), NULL_RTX, + V64SImode, + EXPAND_NORMAL)); + emit_insn (gen_ldexpv64sf3_exec + (target, arg1, arg2, gcn_gen_undef (V64SFmode), exec)); + return target; + } + case GCN_BUILTIN_LDEXPV: + { + if (ignore) + return target; + rtx exec = gcn_full_exec_reg (); + rtx arg1 = force_reg (V64DFmode, + expand_expr (CALL_EXPR_ARG (exp, 0), NULL_RTX, + V64SFmode, + EXPAND_NORMAL)); + rtx arg2 = force_reg (V64SImode, + expand_expr (CALL_EXPR_ARG (exp, 1), NULL_RTX, + V64SImode, + EXPAND_NORMAL)); + emit_insn (gen_ldexpv64df3_exec + (target, arg1, arg2, gcn_gen_undef (V64DFmode), exec)); + return target; + } + case GCN_BUILTIN_FREXPVF_EXP: + { + if (ignore) + return target; + rtx exec = gcn_full_exec_reg (); + rtx arg = force_reg (V64SFmode, + expand_expr (CALL_EXPR_ARG (exp, 0), NULL_RTX, + V64SFmode, + EXPAND_NORMAL)); + emit_insn (gen_frexpv64sf_exp2_exec + (target, arg, gcn_gen_undef (V64SImode), exec)); + return target; + } + case GCN_BUILTIN_FREXPVF_MANT: + { + if (ignore) + return target; + rtx exec = gcn_full_exec_reg (); + rtx arg = force_reg (V64SFmode, + expand_expr (CALL_EXPR_ARG (exp, 0), NULL_RTX, + V64SFmode, + EXPAND_NORMAL)); + emit_insn (gen_frexpv64sf_mant2_exec + (target, arg, gcn_gen_undef (V64SFmode), exec)); + return target; + } + case GCN_BUILTIN_FREXPV_EXP: + { + if (ignore) + return target; + rtx exec = gcn_full_exec_reg (); + rtx arg = force_reg (V64DFmode, + expand_expr (CALL_EXPR_ARG (exp, 0), NULL_RTX, + V64DFmode, + EXPAND_NORMAL)); + emit_insn (gen_frexpv64df_exp2_exec + (target, arg, gcn_gen_undef (V64SImode), exec)); + return target; + } + case GCN_BUILTIN_FREXPV_MANT: + { + if (ignore) + return target; + rtx exec = gcn_full_exec_reg (); + rtx arg = force_reg (V64DFmode, + expand_expr (CALL_EXPR_ARG (exp, 0), NULL_RTX, + V64DFmode, + EXPAND_NORMAL)); + emit_insn (gen_frexpv64df_mant2_exec + (target, arg, gcn_gen_undef (V64DFmode), exec)); + return target; + } case GCN_BUILTIN_OMP_DIM_SIZE: { if (ignore) @@ -6476,7 +6586,7 @@ print_operand (FILE *file, rtx x, int code) str = "-4.0"; break; case 248: - str = "1/pi"; + str = "0.15915494"; break; default: rtx ix = simplify_gen_subreg (GET_MODE (x) == DFmode diff --git a/gcc/config/gcn/gcn.md b/gcc/config/gcn/gcn.md index 7805e86..a3c9523 100644 --- a/gcc/config/gcn/gcn.md +++ b/gcc/config/gcn/gcn.md @@ -82,7 +82,9 @@ UNSPEC_GATHER UNSPEC_SCATTER UNSPEC_RCP - UNSPEC_FLBIT_INT]) + UNSPEC_FLBIT_INT + UNSPEC_FLOOR UNSPEC_CEIL UNSPEC_SIN UNSPEC_COS UNSPEC_EXP2 UNSPEC_LOG2 + UNSPEC_LDEXP UNSPEC_FREXP_EXP UNSPEC_FREXP_MANT]) ;; }}} ;; {{{ Attributes diff --git a/gcc/config/gcn/mkoffload.cc b/gcc/config/gcn/mkoffload.cc index 4206448..24d3273 100644 --- a/gcc/config/gcn/mkoffload.cc +++ b/gcc/config/gcn/mkoffload.cc @@ -553,6 +553,7 @@ process_asm (FILE *in, FILE *out, FILE *cfile) char *funcname; if (sscanf (buf, "\t.8byte\t%ms\n", &funcname)) { + fputs (buf, out); obstack_ptr_grow (&fns_os, funcname); fn_count++; continue; @@ -577,7 +578,15 @@ process_asm (FILE *in, FILE *out, FILE *cfile) out); } else if (sscanf (buf, " .section .gnu.offload_funcs%c", &dummy) > 0) - state = IN_FUNCS; + { + state = IN_FUNCS; + /* Likewise for .gnu.offload_vars; used for reverse offload. */ + fputs (buf, out); + fputs ("\t.global .offload_func_table\n" + "\t.type .offload_func_table, @object\n" + ".offload_func_table:\n", + out); + } else if (sscanf (buf, " .amdgpu_metadata%c", &dummy) > 0) { state = IN_METADATA; diff --git a/gcc/config/glibc-d.cc b/gcc/config/glibc-d.cc index 80ef27d..1411f19 100644 --- a/gcc/config/glibc-d.cc +++ b/gcc/config/glibc-d.cc @@ -19,7 +19,6 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tm.h" -#include "memmodel.h" #include "tm_d.h" #include "d/d-target.h" #include "d/d-target-def.h" diff --git a/gcc/config/i386/i386-builtin.def b/gcc/config/i386/i386-builtin.def index f9c7abd..dea52a2 100644 --- a/gcc/config/i386/i386-builtin.def +++ b/gcc/config/i386/i386-builtin.def @@ -1351,7 +1351,7 @@ BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_avx512f_cmpv8di3_mask, "__builtin_ia BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_avx512f_compressv8df_mask, "__builtin_ia32_compressdf512_mask", IX86_BUILTIN_COMPRESSPD512, UNKNOWN, (int) V8DF_FTYPE_V8DF_V8DF_UQI) BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_avx512f_compressv16sf_mask, "__builtin_ia32_compresssf512_mask", IX86_BUILTIN_COMPRESSPS512, UNKNOWN, (int) V16SF_FTYPE_V16SF_V16SF_UHI) BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_floatv8siv8df2_mask, "__builtin_ia32_cvtdq2pd512_mask", IX86_BUILTIN_CVTDQ2PD512, UNKNOWN, (int) V8DF_FTYPE_V8SI_V8DF_UQI) -BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_avx512f_vcvtps2ph512_mask, "__builtin_ia32_vcvtps2ph512_mask", IX86_BUILTIN_CVTPS2PH512, UNKNOWN, (int) V16HI_FTYPE_V16SF_INT_V16HI_UHI) +BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_avx512f_vcvtps2ph512_mask_sae, "__builtin_ia32_vcvtps2ph512_mask", IX86_BUILTIN_CVTPS2PH512, UNKNOWN, (int) V16HI_FTYPE_V16SF_INT_V16HI_UHI) BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_ufloatv8siv8df2_mask, "__builtin_ia32_cvtudq2pd512_mask", IX86_BUILTIN_CVTUDQ2PD512, UNKNOWN, (int) V8DF_FTYPE_V8SI_V8DF_UQI) BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_cvtusi2sd32, "__builtin_ia32_cvtusi2sd32", IX86_BUILTIN_CVTUSI2SD32, UNKNOWN, (int) V2DF_FTYPE_V2DF_UINT) BDESC (OPTION_MASK_ISA_AVX512F, 0, CODE_FOR_expandv8df_mask, "__builtin_ia32_expanddf512_mask", IX86_BUILTIN_EXPANDPD512, UNKNOWN, (int) V8DF_FTYPE_V8DF_V8DF_UQI) diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index 72acf0b..d535c0a 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -26903,14 +26903,40 @@ (set_attr "btver2_decode" "vector") (set_attr "mode" "V8SF")]) -(define_insn "<mask_codefor>avx512f_vcvtps2ph512<mask_name>" +;; vcvtps2ph is special, it encodes {sae} in evex, but round control in the imm +;; For intrinsic _mm512_cvt_roundps_ph (a, imm), imm contains both {sae} +;; and round control, we need to separate it in the assembly output. +;; op2 in avx512f_vcvtps2ph512_mask_sae contains both sae and round control. +(define_expand "avx512f_vcvtps2ph512_mask_sae" + [(set (match_operand:V16HI 0 "register_operand" "=v") + (vec_merge:V16HI + (unspec:V16HI + [(match_operand:V16SF 1 "register_operand" "v") + (match_operand:SI 2 "const_0_to_255_operand")] + UNSPEC_VCVTPS2PH) + (match_operand:V16HI 3 "nonimm_or_0_operand") + (match_operand:HI 4 "register_operand")))] + "TARGET_AVX512F" +{ + int round = INTVAL (operands[2]); + /* Separate {sae} from rounding control imm, + imm[3:7] will be ignored by the instruction. */ + if (round & 8) + { + emit_insn (gen_avx512f_vcvtps2ph512_mask_round (operands[0], operands[1], + operands[2], operands[3], operands[4], GEN_INT (8))); + DONE; + } +}) + +(define_insn "<mask_codefor>avx512f_vcvtps2ph512<mask_name><round_saeonly_name>" [(set (match_operand:V16HI 0 "register_operand" "=v") (unspec:V16HI [(match_operand:V16SF 1 "register_operand" "v") (match_operand:SI 2 "const_0_to_255_operand")] UNSPEC_VCVTPS2PH))] "TARGET_AVX512F" - "vcvtps2ph\t{%2, %1, %0<mask_operand3>|%0<mask_operand3>, %1, %2}" + "vcvtps2ph\t{%2, <round_saeonly_mask_op3>%1, %0<mask_operand3>|%0<mask_operand3>, %1<round_saeonly_mask_op3>, %2}" [(set_attr "type" "ssecvt") (set_attr "prefix" "evex") (set_attr "mode" "V16SF")]) diff --git a/gcc/config/loongarch/loongarch.cc b/gcc/config/loongarch/loongarch.cc index c9187bf..98c0e26 100644 --- a/gcc/config/loongarch/loongarch.cc +++ b/gcc/config/loongarch/loongarch.cc @@ -6466,6 +6466,16 @@ loongarch_use_anchors_for_symbol_p (const_rtx symbol) return default_use_anchors_for_symbol_p (symbol); } +/* Implement the TARGET_ASAN_SHADOW_OFFSET hook. */ + +static unsigned HOST_WIDE_INT +loongarch_asan_shadow_offset (void) +{ + /* We only have libsanitizer support for LOONGARCH64 at present. + This value is taken from the file libsanitizer/asan/asan_mappint.h. */ + return TARGET_64BIT ? (HOST_WIDE_INT_1 << 46) : 0; +} + /* Initialize the GCC target structure. */ #undef TARGET_ASM_ALIGNED_HI_OP #define TARGET_ASM_ALIGNED_HI_OP "\t.half\t" @@ -6660,6 +6670,9 @@ loongarch_use_anchors_for_symbol_p (const_rtx symbol) #undef TARGET_USE_ANCHORS_FOR_SYMBOL_P #define TARGET_USE_ANCHORS_FOR_SYMBOL_P loongarch_use_anchors_for_symbol_p +#undef TARGET_ASAN_SHADOW_OFFSET +#define TARGET_ASAN_SHADOW_OFFSET loongarch_asan_shadow_offset + struct gcc_target targetm = TARGET_INITIALIZER; #include "gt-loongarch.h" diff --git a/gcc/config/msp430/msp430.cc b/gcc/config/msp430/msp430.cc index 7a378ce..6c15780 100644 --- a/gcc/config/msp430/msp430.cc +++ b/gcc/config/msp430/msp430.cc @@ -1460,7 +1460,7 @@ msp430_get_inner_dest_code (rtx x) /* Calculate the cost of an MSP430 single-operand instruction, for operand DST within the RTX OUTER_RTX, optimizing for speed if SPEED is true. */ static int -msp430_single_op_cost (rtx dst, bool speed, rtx outer_rtx) +msp430_single_op_cost (rtx dst, bool speed, rtx /* outer_rtx */) { enum rtx_code dst_code = GET_CODE (dst); const struct single_op_cost *cost_p; diff --git a/gcc/config/netbsd-d.cc b/gcc/config/netbsd-d.cc index cd0c955..dbabae7 100644 --- a/gcc/config/netbsd-d.cc +++ b/gcc/config/netbsd-d.cc @@ -20,6 +20,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "tm.h" #include "tm_d.h" #include "d/d-target.h" #include "d/d-target-def.h" diff --git a/gcc/config/nios2/linux.h b/gcc/config/nios2/linux.h index f5dd813..9e53dd6 100644 --- a/gcc/config/nios2/linux.h +++ b/gcc/config/nios2/linux.h @@ -30,6 +30,8 @@ #define CPP_SPEC "%{posix:-D_POSIX_SOURCE} %{pthread:-D_REENTRANT}" #define GLIBC_DYNAMIC_LINKER "/lib/ld-linux-nios2.so.1" + +#undef MUSL_DYNAMIC_LINKER #define MUSL_DYNAMIC_LINKER "/lib/ld-musl-nios2.so.1" #undef LINK_SPEC diff --git a/gcc/config/nvptx/mkoffload.cc b/gcc/config/nvptx/mkoffload.cc index 3eea0a8..834b205 100644 --- a/gcc/config/nvptx/mkoffload.cc +++ b/gcc/config/nvptx/mkoffload.cc @@ -47,6 +47,7 @@ struct id_map { id_map *next; char *ptx_name; + char *dim; }; static id_map *func_ids, **funcs_tail = &func_ids; @@ -108,8 +109,11 @@ xputenv (const char *string) static void record_id (const char *p1, id_map ***where) { - const char *end = strchr (p1, '\n'); - if (!end) + gcc_assert (p1[0] == '"'); + p1++; + const char *end = strchr (p1, '"'); + const char *end2 = strchr (p1, '\n'); + if (!end || !end2 || end >= end2) fatal_error (input_location, "malformed ptx file"); id_map *v = XNEW (id_map); @@ -117,6 +121,16 @@ record_id (const char *p1, id_map ***where) v->ptx_name = XNEWVEC (char, len + 1); memcpy (v->ptx_name, p1, len); v->ptx_name[len] = '\0'; + p1 = end + 1; + if (*end != '\n') + { + len = end2 - p1; + v->dim = XNEWVEC (char, len + 1); + memcpy (v->dim, p1, len); + v->dim[len] = '\0'; + } + else + v->dim = NULL; v->next = NULL; id_map **tail = *where; *tail = v; @@ -242,6 +256,10 @@ process (FILE *in, FILE *out, uint32_t omp_requires) id_map const *id; unsigned obj_count = 0; 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); fprintf (out, "#include <stdint.h>\n\n"); @@ -250,6 +268,8 @@ process (FILE *in, FILE *out, uint32_t omp_requires) for (size_t i = 0; i != len;) { 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++])) @@ -261,6 +281,16 @@ process (FILE *in, FILE *out, uint32_t omp_requires) case '\n': fprintf (out, "\\n\"\n\t\""); /* Look for mappings on subsequent lines. */ + if (UNLIKELY (startswith (input + i, ".target sm_"))) + { + sm_ver = input + i + strlen (".target sm_"); + continue; + } + if (UNLIKELY (startswith (input + i, ".version "))) + { + version = input + i + strlen (".version "); + continue; + } while (startswith (input + i, "//:")) { i += 3; @@ -268,7 +298,10 @@ process (FILE *in, FILE *out, uint32_t omp_requires) if (startswith (input + i, "VAR_MAP ")) record_id (input + i + 8, &vars_tail); else if (startswith (input + i, "FUNC_MAP ")) - record_id (input + i + 9, &funcs_tail); + { + output_fn_ptr = true; + record_id (input + i + 9, &funcs_tail); + } else abort (); /* Skip to next line. */ @@ -286,6 +319,81 @@ process (FILE *in, FILE *out, uint32_t omp_requires) putc (c, out); } fprintf (out, "\";\n\n"); + if (output_fn_ptr + && (omp_requires & GOMP_REQUIRES_REVERSE_OFFLOAD) != 0) + { + if (sm_ver && sm_ver[0] == '3' && sm_ver[1] == '0' + && sm_ver[2] == '\n') + fatal_error (input_location, + "%<omp requires reverse_offload%> requires at least " + "%<sm_35%> for %<-misa=%>"); + sm_ver2 = sm_ver; + version2 = version; + } + } + + /* Create function-pointer array, required for reverse + offload function-pointer lookup. */ + + if (func_ids && (omp_requires & GOMP_REQUIRES_REVERSE_OFFLOAD) != 0) + { + const char needle[] = "// BEGIN GLOBAL FUNCTION DECL: "; + fprintf (out, "static const char ptx_code_%u[] =\n", obj_count++); + fprintf (out, "\t\".version "); + for (size_t i = 0; version2[i] != '\0' && version2[i] != '\n'; i++) + fputc (version2[i], out); + fprintf (out, "\"\n\t\".target sm_"); + for (size_t i = 0; version2[i] != '\0' && sm_ver2[i] != '\n'; i++) + fputc (sm_ver2[i], out); + fprintf (out, "\"\n\t\".file 1 \\\"<dummy>\\\"\"\n"); + + size_t fidx = 0; + for (id = func_ids; id; id = id->next) + { + /* Only 'nohost' functions are needed - use NULL for the rest. + Alternatively, besides searching for 'BEGIN FUNCTION DECL', + checking for '.visible .entry ' + id->ptx_name would be + required. */ + if (!endswith (id->ptx_name, "$nohost")) + continue; + fprintf (out, "\t\".extern "); + const char *p = input + file_idx[fidx]; + while (true) + { + p = strstr (p, needle); + if (!p) + { + fidx++; + if (fidx >= file_cnt) + break; + p = input + file_idx[fidx]; + continue; + } + p += strlen (needle); + if (!startswith (p, id->ptx_name)) + continue; + p += strlen (id->ptx_name); + if (*p != '\n') + continue; + p++; + gcc_assert (startswith (p, ".visible ")); + p += strlen (".visible "); + for (; *p != '\0' && *p != '\n'; p++) + fputc (*p, out); + break; + } + fprintf (out, "\"\n"); + if (fidx == file_cnt) + fatal_error (input_location, + "Cannot find function declaration for %qs", + id->ptx_name); + } + fprintf (out, "\t\".visible .global .align 8 .u64 " + "$offload_func_table[] = {"); + for (comma = "", id = func_ids; id; comma = ",", id = id->next) + fprintf (out, "%s\"\n\t\t\"%s", comma, + endswith (id->ptx_name, "$nohost") ? id->ptx_name : "0"); + fprintf (out, "};\\n\";\n\n"); } /* Dump out array of pointers to ptx object strings. */ @@ -300,7 +408,7 @@ process (FILE *in, FILE *out, uint32_t omp_requires) /* Dump out variable idents. */ fprintf (out, "static const char *const var_mappings[] = {"); for (comma = "", id = var_ids; id; comma = ",", id = id->next) - fprintf (out, "%s\n\t%s", comma, id->ptx_name); + fprintf (out, "%s\n\t\"%s\"", comma, id->ptx_name); fprintf (out, "\n};\n\n"); /* Dump out function idents. */ @@ -309,7 +417,8 @@ process (FILE *in, FILE *out, uint32_t omp_requires) " unsigned short dim[%d];\n" "} func_mappings[] = {\n", GOMP_DIM_MAX); for (comma = "", id = func_ids; id; comma = ",", id = id->next) - fprintf (out, "%s\n\t{%s}", comma, id->ptx_name); + fprintf (out, "%s\n\t{\"%s\"%s}", comma, id->ptx_name, + id->dim ? id->dim : ""); fprintf (out, "\n};\n\n"); fprintf (out, diff --git a/gcc/config/nvptx/nvptx.cc b/gcc/config/nvptx/nvptx.cc index 3634a49..49cc681 100644 --- a/gcc/config/nvptx/nvptx.cc +++ b/gcc/config/nvptx/nvptx.cc @@ -988,15 +988,15 @@ write_var_marker (FILE *file, bool is_defn, bool globalize, const char *name) static void write_fn_proto_1 (std::stringstream &s, bool is_defn, - const char *name, const_tree decl) + const char *name, const_tree decl, bool force_public) { if (lookup_attribute ("alias", DECL_ATTRIBUTES (decl)) == NULL) - write_fn_marker (s, is_defn, TREE_PUBLIC (decl), name); + write_fn_marker (s, is_defn, TREE_PUBLIC (decl) || force_public, name); /* PTX declaration. */ if (DECL_EXTERNAL (decl)) s << ".extern "; - else if (TREE_PUBLIC (decl)) + else if (TREE_PUBLIC (decl) || force_public) s << (DECL_WEAK (decl) ? ".weak " : ".visible "); s << (write_as_kernel (DECL_ATTRIBUTES (decl)) ? ".entry " : ".func "); @@ -1085,7 +1085,7 @@ write_fn_proto_1 (std::stringstream &s, bool is_defn, static void write_fn_proto (std::stringstream &s, bool is_defn, - const char *name, const_tree decl) + const char *name, const_tree decl, bool force_public=false) { const char *replacement = nvptx_name_replacement (name); char *replaced_dots = NULL; @@ -1102,9 +1102,9 @@ write_fn_proto (std::stringstream &s, bool is_defn, if (is_defn) /* Emit a declaration. The PTX assembler gets upset without it. */ - write_fn_proto_1 (s, false, name, decl); + write_fn_proto_1 (s, false, name, decl, force_public); - write_fn_proto_1 (s, is_defn, name, decl); + write_fn_proto_1 (s, is_defn, name, decl, force_public); if (replaced_dots) XDELETE (replaced_dots); @@ -1480,7 +1480,13 @@ nvptx_declare_function_name (FILE *file, const char *name, const_tree decl) tree fntype = TREE_TYPE (decl); tree result_type = TREE_TYPE (fntype); int argno = 0; + bool force_public = false; + /* For reverse-offload 'nohost' functions: In order to be collectable in + '$offload_func_table', cf. mkoffload.cc, the function has to be visible. */ + if (lookup_attribute ("omp target device_ancestor_nohost", + DECL_ATTRIBUTES (decl))) + force_public = true; if (lookup_attribute ("omp target entrypoint", DECL_ATTRIBUTES (decl)) && !lookup_attribute ("oacc function", DECL_ATTRIBUTES (decl))) { @@ -1492,7 +1498,7 @@ nvptx_declare_function_name (FILE *file, const char *name, const_tree decl) /* We construct the initial part of the function into a string stream, in order to share the prototype writing code. */ std::stringstream s; - write_fn_proto (s, true, name, decl); + write_fn_proto (s, true, name, decl, force_public); s << "{\n"; bool return_in_mem = write_return_type (s, false, result_type); diff --git a/gcc/config/openbsd-d.cc b/gcc/config/openbsd-d.cc index 33c7e41..bb3a3f2 100644 --- a/gcc/config/openbsd-d.cc +++ b/gcc/config/openbsd-d.cc @@ -20,6 +20,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "tm.h" #include "tm_d.h" #include "d/d-target.h" #include "d/d-target-def.h" diff --git a/gcc/config/rs6000/rs6000.cc b/gcc/config/rs6000/rs6000.cc index 8b4edd2..bcf634a 100644 --- a/gcc/config/rs6000/rs6000.cc +++ b/gcc/config/rs6000/rs6000.cc @@ -3821,6 +3821,12 @@ rs6000_option_override_internal (bool global_init_p) if (TARGET_DEBUG_REG || TARGET_DEBUG_TARGET) rs6000_print_isa_options (stderr, 0, "before defaults", rs6000_isa_flags); +#ifdef XCOFF_DEBUGGING_INFO + /* For AIX default to 64-bit DWARF. */ + if (!OPTION_SET_P (dwarf_offset_size)) + dwarf_offset_size = POINTER_SIZE_UNITS; +#endif + /* Handle explicit -mno-{altivec,vsx,power8-vector,power9-vector} and turn off all of the options that depend on those flags. */ ignore_masks = rs6000_disable_incompatible_switches (); @@ -18108,7 +18114,7 @@ get_memref_parts (rtx mem, rtx *base, HOST_WIDE_INT *offset, HOST_WIDE_INT *size) { rtx addr_rtx; - if MEM_SIZE_KNOWN_P (mem) + if (MEM_SIZE_KNOWN_P (mem)) *size = MEM_SIZE (mem); else return false; @@ -20940,6 +20946,11 @@ rs6000_elf_file_end (void) #if TARGET_XCOFF +#ifndef HAVE_XCOFF_DWARF_EXTRAS +#define HAVE_XCOFF_DWARF_EXTRAS 0 +#endif + + /* Names of bss and data sections. These should be unique names for each compilation unit. */ diff --git a/gcc/config/rs6000/rs6000.md b/gcc/config/rs6000/rs6000.md index e9e5cd1..ad5a4cf 100644 --- a/gcc/config/rs6000/rs6000.md +++ b/gcc/config/rs6000/rs6000.md @@ -7773,11 +7773,7 @@ [(set (match_operand:SI 0 "gpc_reg_operand") (match_operand:SI 1 "const_int_operand"))] "num_insns_constant (operands[1], SImode) > 1" - [(set (match_dup 0) - (match_dup 2)) - (set (match_dup 0) - (ior:SI (match_dup 0) - (match_dup 3)))] + [(pc)] { if (rs6000_emit_set_const (operands[0], operands[1])) DONE; @@ -9687,7 +9683,7 @@ ; Some DImode loads are best done as a load of -1 followed by a mask ; instruction. (define_split - [(set (match_operand:DI 0 "int_reg_operand_not_pseudo") + [(set (match_operand:DI 0 "int_reg_operand") (match_operand:DI 1 "const_int_operand"))] "TARGET_POWERPC64 && num_insns_constant (operands[1], DImode) > 1 @@ -9705,24 +9701,10 @@ ;; When non-easy constants can go in the TOC, this should use ;; easy_fp_constant predicate. (define_split - [(set (match_operand:DI 0 "int_reg_operand_not_pseudo") + [(set (match_operand:DI 0 "int_reg_operand") (match_operand:DI 1 "const_int_operand"))] "TARGET_POWERPC64 && num_insns_constant (operands[1], DImode) > 1" - [(set (match_dup 0) (match_dup 2)) - (set (match_dup 0) (plus:DI (match_dup 0) (match_dup 3)))] -{ - if (rs6000_emit_set_const (operands[0], operands[1])) - DONE; - else - FAIL; -}) - -(define_split - [(set (match_operand:DI 0 "int_reg_operand_not_pseudo") - (match_operand:DI 1 "const_scalar_int_operand"))] - "TARGET_POWERPC64 && num_insns_constant (operands[1], DImode) > 1" - [(set (match_dup 0) (match_dup 2)) - (set (match_dup 0) (plus:DI (match_dup 0) (match_dup 3)))] + [(pc)] { if (rs6000_emit_set_const (operands[0], operands[1])) DONE; diff --git a/gcc/config/rs6000/rtems.h b/gcc/config/rs6000/rtems.h index d529e22..8437015 100644 --- a/gcc/config/rs6000/rtems.h +++ b/gcc/config/rs6000/rtems.h @@ -255,7 +255,8 @@ %{mcpu=821: %{!Dppc*: %{!Dmpc*: -Dmpc821} } } \ %{mcpu=860: %{!Dppc*: %{!Dmpc*: -Dmpc860} } } \ %{mcpu=8540: %{!Dppc*: %{!Dmpc*: -Dppc8540} } } \ -%{mcpu=e6500: -D__PPC_CPU_E6500__}" +%{mcpu=e6500: -D__PPC_CPU_E6500__} \ +%{mvrsave: -D__PPC_VRSAVE__}" #undef ASM_SPEC #define ASM_SPEC "%{!m64:%(asm_spec32)}%{m64:%(asm_spec64)} %(asm_spec_common)" diff --git a/gcc/config/rs6000/t-rtems b/gcc/config/rs6000/t-rtems index 4f8c147..9da2da6 100644 --- a/gcc/config/rs6000/t-rtems +++ b/gcc/config/rs6000/t-rtems @@ -36,6 +36,9 @@ MULTILIB_DIRNAMES += nof MULTILIB_OPTIONS += mno-altivec MULTILIB_DIRNAMES += noaltivec +MULTILIB_OPTIONS += mvrsave +MULTILIB_DIRNAMES += vrsave + MULTILIB_MATCHES += ${MULTILIB_MATCHES_ENDIAN} MULTILIB_MATCHES += ${MULTILIB_MATCHES_SYSV} # Map 405 to 403 @@ -70,5 +73,7 @@ MULTILIB_REQUIRED += mcpu=7400/msoft-float MULTILIB_REQUIRED += mcpu=8540/msoft-float MULTILIB_REQUIRED += mcpu=860 MULTILIB_REQUIRED += mcpu=e6500/m32 +MULTILIB_REQUIRED += mcpu=e6500/m32/mvrsave MULTILIB_REQUIRED += mcpu=e6500/m32/msoft-float/mno-altivec MULTILIB_REQUIRED += mcpu=e6500/m64 +MULTILIB_REQUIRED += mcpu=e6500/m64/mvrsave diff --git a/gcc/config/rs6000/xcoff.h b/gcc/config/rs6000/xcoff.h index bafc57d..cd0f99c 100644 --- a/gcc/config/rs6000/xcoff.h +++ b/gcc/config/rs6000/xcoff.h @@ -21,6 +21,9 @@ #define TARGET_OBJECT_FORMAT OBJECT_XCOFF +/* The RS/6000 uses the XCOFF format. */ +#define XCOFF_DEBUGGING_INFO 1 + /* Define if the object format being used is COFF or a superset. */ #define OBJECT_FORMAT_COFF diff --git a/gcc/config/sol2-d.cc b/gcc/config/sol2-d.cc index 0ace79d..cecb49c 100644 --- a/gcc/config/sol2-d.cc +++ b/gcc/config/sol2-d.cc @@ -18,6 +18,7 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "tm.h" #include "tm_d.h" #include "d/d-target.h" #include "d/d-target-def.h" diff --git a/gcc/config/xtensa/linux.h b/gcc/config/xtensa/linux.h index 540e4bf..bc7bee7 100644 --- a/gcc/config/xtensa/linux.h +++ b/gcc/config/xtensa/linux.h @@ -54,9 +54,10 @@ along with GCC; see the file COPYING3. If not see #define LINK_SPEC \ "%{shared:-shared} \ %{!shared: \ - %{!static: \ + %{!static:%{!static-pie: \ %{rdynamic:-export-dynamic} \ - -dynamic-linker " GNU_USER_DYNAMIC_LINKER "} \ + -dynamic-linker " GNU_USER_DYNAMIC_LINKER "}} \ + %{static-pie:-static -pie --no-dynamic-linker -z text} \ %{static:-static}} \ %{mabi=windowed:--abi-windowed} \ %{mabi=call0:--abi-call0}" diff --git a/gcc/config/xtensa/xtensa.cc b/gcc/config/xtensa/xtensa.cc index 93ac656..ac52c01 100644 --- a/gcc/config/xtensa/xtensa.cc +++ b/gcc/config/xtensa/xtensa.cc @@ -102,6 +102,7 @@ struct GTY(()) machine_function int callee_save_size; bool frame_laid_out; bool epilogue_done; + bool inhibit_logues_a1_adjusts; }; /* Vector, indexed by hard register number, which contains 1 for a @@ -1141,6 +1142,37 @@ xtensa_constantsynth (rtx dst, HOST_WIDE_INT srcval) xtensa_constantsynth_rtx_ADDSUBX, divisor)) return 1; + + /* loading simm12 followed by left/right bitwise rotation: + MOVI + SSAI + SRC. */ + if ((srcval & 0x001FF800) == 0 + || (srcval & 0x001FF800) == 0x001FF800) + { + int32_t v; + + for (shift = 1; shift < 12; ++shift) + { + v = (int32_t)(((uint32_t)srcval >> shift) + | ((uint32_t)srcval << (32 - shift))); + if (xtensa_simm12b(v)) + { + emit_move_insn (dst, GEN_INT (v)); + emit_insn (gen_rotlsi3 (dst, dst, GEN_INT (shift))); + return 1; + } + } + for (shift = 1; shift < 12; ++shift) + { + v = (int32_t)(((uint32_t)srcval << shift) + | ((uint32_t)srcval >> (32 - shift))); + if (xtensa_simm12b(v)) + { + emit_move_insn (dst, GEN_INT (v)); + emit_insn (gen_rotrsi3 (dst, dst, GEN_INT (shift))); + return 1; + } + } + } } return 0; @@ -3048,7 +3080,7 @@ xtensa_output_literal (FILE *file, rtx x, machine_mode mode, int labelno) } static bool -xtensa_call_save_reg(int regno) +xtensa_call_save_reg (int regno) { if (TARGET_WINDOWED_ABI) return false; @@ -3084,7 +3116,7 @@ compute_frame_size (poly_int64 size) cfun->machine->callee_save_size = 0; for (regno = 0; regno < FIRST_PSEUDO_REGISTER; ++regno) { - if (xtensa_call_save_reg(regno)) + if (xtensa_call_save_reg (regno)) cfun->machine->callee_save_size += UNITS_PER_WORD; } @@ -3139,6 +3171,49 @@ xtensa_initial_elimination_offset (int from, int to ATTRIBUTE_UNUSED) return offset; } +#define ADJUST_SP_NONE 0x0 +#define ADJUST_SP_NEED_NOTE 0x1 +#define ADJUST_SP_FRAME_PTR 0x2 +static void +xtensa_emit_adjust_stack_ptr (HOST_WIDE_INT offset, int flags) +{ + rtx_insn *insn; + rtx ptr = (flags & ADJUST_SP_FRAME_PTR) ? hard_frame_pointer_rtx + : stack_pointer_rtx; + + if (cfun->machine->inhibit_logues_a1_adjusts) + return; + + if (xtensa_simm8 (offset) + || xtensa_simm8x256 (offset)) + insn = emit_insn (gen_addsi3 (stack_pointer_rtx, ptr, GEN_INT (offset))); + else + { + rtx tmp_reg = gen_rtx_REG (Pmode, A9_REG); + + if (offset < 0) + { + emit_move_insn (tmp_reg, GEN_INT (-offset)); + insn = emit_insn (gen_subsi3 (stack_pointer_rtx, ptr, tmp_reg)); + } + else + { + emit_move_insn (tmp_reg, GEN_INT (offset)); + insn = emit_insn (gen_addsi3 (stack_pointer_rtx, ptr, tmp_reg)); + } + } + + if (flags & ADJUST_SP_NEED_NOTE) + { + rtx note_rtx = gen_rtx_SET (stack_pointer_rtx, + plus_constant (Pmode, stack_pointer_rtx, + offset)); + + RTX_FRAME_RELATED_P (insn) = 1; + add_reg_note (insn, REG_FRAME_RELATED_EXPR, note_rtx); + } +} + /* minimum frame = reg save area (4 words) plus static chain (1 word) and the total number of words must be a multiple of 128 bits. */ #define MIN_FRAME_SIZE (8 * UNITS_PER_WORD) @@ -3174,17 +3249,30 @@ xtensa_expand_prologue (void) int regno; HOST_WIDE_INT offset = 0; int callee_save_size = cfun->machine->callee_save_size; + df_ref ref; + bool stack_pointer_needed = frame_pointer_needed + || crtl->calls_eh_return; + + /* Check if the function body really needs the stack pointer. */ + if (!stack_pointer_needed) + for (ref = DF_REG_USE_CHAIN (A1_REG); + ref; ref = DF_REF_NEXT_REG (ref)) + if (DF_REF_CLASS (ref) == DF_REF_REGULAR + && NONJUMP_INSN_P (DF_REF_INSN (ref))) + stack_pointer_needed = true; + /* Check if callee-saved registers really need saving to the stack. */ + if (!stack_pointer_needed) + for (regno = 0; regno < FIRST_PSEUDO_REGISTER; ++regno) + if (xtensa_call_save_reg (regno)) + stack_pointer_needed = true; + + cfun->machine->inhibit_logues_a1_adjusts = !stack_pointer_needed; /* -128 is a limit of single addi instruction. */ if (IN_RANGE (total_size, 1, 128)) { - insn = emit_insn (gen_addsi3 (stack_pointer_rtx, stack_pointer_rtx, - GEN_INT (-total_size))); - RTX_FRAME_RELATED_P (insn) = 1; - note_rtx = gen_rtx_SET (stack_pointer_rtx, - plus_constant (Pmode, stack_pointer_rtx, - -total_size)); - add_reg_note (insn, REG_FRAME_RELATED_EXPR, note_rtx); + xtensa_emit_adjust_stack_ptr (-total_size, + ADJUST_SP_NEED_NOTE); offset = total_size - UNITS_PER_WORD; } else if (callee_save_size) @@ -3194,33 +3282,14 @@ xtensa_expand_prologue (void) * move it to its final location. */ if (total_size > 1024) { - insn = emit_insn (gen_addsi3 (stack_pointer_rtx, stack_pointer_rtx, - GEN_INT (-callee_save_size))); - RTX_FRAME_RELATED_P (insn) = 1; - note_rtx = gen_rtx_SET (stack_pointer_rtx, - plus_constant (Pmode, stack_pointer_rtx, - -callee_save_size)); - add_reg_note (insn, REG_FRAME_RELATED_EXPR, note_rtx); + xtensa_emit_adjust_stack_ptr (-callee_save_size, + ADJUST_SP_NEED_NOTE); offset = callee_save_size - UNITS_PER_WORD; } else { - if (xtensa_simm8x256 (-total_size)) - insn = emit_insn (gen_addsi3 (stack_pointer_rtx, - stack_pointer_rtx, - GEN_INT (-total_size))); - else - { - rtx tmp_reg = gen_rtx_REG (Pmode, A9_REG); - emit_move_insn (tmp_reg, GEN_INT (total_size)); - insn = emit_insn (gen_subsi3 (stack_pointer_rtx, - stack_pointer_rtx, tmp_reg)); - } - RTX_FRAME_RELATED_P (insn) = 1; - note_rtx = gen_rtx_SET (stack_pointer_rtx, - plus_constant (Pmode, stack_pointer_rtx, - -total_size)); - add_reg_note (insn, REG_FRAME_RELATED_EXPR, note_rtx); + xtensa_emit_adjust_stack_ptr (-total_size, + ADJUST_SP_NEED_NOTE); offset = total_size - UNITS_PER_WORD; } } @@ -3242,27 +3311,8 @@ xtensa_expand_prologue (void) } if (total_size > 1024 || (!callee_save_size && total_size > 128)) - { - if (xtensa_simm8x256 (callee_save_size - total_size)) - insn = emit_insn (gen_addsi3 (stack_pointer_rtx, - stack_pointer_rtx, - GEN_INT (callee_save_size - - total_size))); - else - { - rtx tmp_reg = gen_rtx_REG (Pmode, A9_REG); - emit_move_insn (tmp_reg, GEN_INT (total_size - - callee_save_size)); - insn = emit_insn (gen_subsi3 (stack_pointer_rtx, - stack_pointer_rtx, tmp_reg)); - } - RTX_FRAME_RELATED_P (insn) = 1; - note_rtx = gen_rtx_SET (stack_pointer_rtx, - plus_constant (Pmode, stack_pointer_rtx, - callee_save_size - - total_size)); - add_reg_note (insn, REG_FRAME_RELATED_EXPR, note_rtx); - } + xtensa_emit_adjust_stack_ptr (callee_save_size - total_size, + ADJUST_SP_NEED_NOTE); } if (frame_pointer_needed) @@ -3329,21 +3379,11 @@ xtensa_expand_epilogue (bool sibcall_p) if (cfun->machine->current_frame_size > (frame_pointer_needed ? 127 : 1024)) { - if (xtensa_simm8x256 (cfun->machine->current_frame_size - - cfun->machine->callee_save_size)) - emit_insn (gen_addsi3 (stack_pointer_rtx, frame_pointer_needed ? - hard_frame_pointer_rtx : stack_pointer_rtx, - GEN_INT (cfun->machine->current_frame_size - - cfun->machine->callee_save_size))); - else - { - rtx tmp_reg = gen_rtx_REG (Pmode, A9_REG); - emit_move_insn (tmp_reg, GEN_INT (cfun->machine->current_frame_size - - cfun->machine->callee_save_size)); - emit_insn (gen_addsi3 (stack_pointer_rtx, frame_pointer_needed ? - hard_frame_pointer_rtx : stack_pointer_rtx, - tmp_reg)); - } + xtensa_emit_adjust_stack_ptr (cfun->machine->current_frame_size - + cfun->machine->callee_save_size, + frame_pointer_needed + ? ADJUST_SP_FRAME_PTR + : ADJUST_SP_NONE); offset = cfun->machine->callee_save_size - UNITS_PER_WORD; } else @@ -3384,24 +3424,11 @@ xtensa_expand_epilogue (bool sibcall_p) else offset = cfun->machine->callee_save_size; if (offset) - emit_insn (gen_addsi3 (stack_pointer_rtx, - stack_pointer_rtx, - GEN_INT (offset))); + xtensa_emit_adjust_stack_ptr (offset, ADJUST_SP_NONE); } else - { - if (xtensa_simm8x256 (cfun->machine->current_frame_size)) - emit_insn (gen_addsi3 (stack_pointer_rtx, stack_pointer_rtx, - GEN_INT (cfun->machine->current_frame_size))); - else - { - rtx tmp_reg = gen_rtx_REG (Pmode, A9_REG); - emit_move_insn (tmp_reg, - GEN_INT (cfun->machine->current_frame_size)); - emit_insn (gen_addsi3 (stack_pointer_rtx, stack_pointer_rtx, - tmp_reg)); - } - } + xtensa_emit_adjust_stack_ptr (cfun->machine->current_frame_size, + ADJUST_SP_NONE); } if (crtl->calls_eh_return) diff --git a/gcc/config/xtensa/xtensa.md b/gcc/config/xtensa/xtensa.md index 3ed2692..f722ea5 100644 --- a/gcc/config/xtensa/xtensa.md +++ b/gcc/config/xtensa/xtensa.md @@ -86,10 +86,6 @@ ;; This code iterator is for *shlrd and its variants. (define_code_iterator ior_op [ior plus]) -;; This mode iterator allows the DC and SC patterns to be defined from -;; the same template. -(define_mode_iterator DSC [DC SC]) - ;; Attributes. @@ -2843,27 +2839,54 @@ }) (define_split - [(clobber (match_operand:DSC 0 "register_operand"))] - "GP_REG_P (REGNO (operands[0]))" + [(clobber (match_operand 0 "register_operand"))] + "HARD_REGISTER_P (operands[0]) + && COMPLEX_MODE_P (GET_MODE (operands[0]))" [(const_int 0)] { - unsigned int regno = REGNO (operands[0]); - machine_mode inner_mode = GET_MODE_INNER (<MODE>mode); + auto_sbitmap bmp (FIRST_PSEUDO_REGISTER); rtx_insn *insn; - rtx x; - if (! ((insn = next_nonnote_nondebug_insn (curr_insn)) - && NONJUMP_INSN_P (insn) - && GET_CODE (x = PATTERN (insn)) == SET - && REG_P (x = XEXP (x, 0)) - && GET_MODE (x) == inner_mode - && REGNO (x) == regno - && (insn = next_nonnote_nondebug_insn (insn)) - && NONJUMP_INSN_P (insn) - && GET_CODE (x = PATTERN (insn)) == SET - && REG_P (x = XEXP (x, 0)) - && GET_MODE (x) == inner_mode - && REGNO (x) == regno + REG_NREGS (operands[0]) / 2)) - FAIL; + rtx reg = gen_rtx_REG (SImode, 0); + bitmap_set_range (bmp, REGNO (operands[0]), REG_NREGS (operands[0])); + for (insn = next_nonnote_nondebug_insn_bb (curr_insn); + insn; insn = next_nonnote_nondebug_insn_bb (insn)) + { + sbitmap_iterator iter; + unsigned int regno; + if (NONJUMP_INSN_P (insn)) + { + EXECUTE_IF_SET_IN_BITMAP (bmp, 2, regno, iter) + { + set_regno_raw (reg, regno, REG_NREGS (reg)); + if (reg_overlap_mentioned_p (reg, PATTERN (insn))) + break; + } + if (GET_CODE (PATTERN (insn)) == SET) + { + rtx x = SET_DEST (PATTERN (insn)); + if (REG_P (x) && HARD_REGISTER_P (x)) + bitmap_clear_range (bmp, REGNO (x), REG_NREGS (x)); + else if (SUBREG_P (x) && HARD_REGISTER_P (SUBREG_REG (x))) + { + struct subreg_info info; + subreg_get_info (regno = REGNO (SUBREG_REG (x)), + GET_MODE (SUBREG_REG (x)), + SUBREG_BYTE (x), GET_MODE (x), &info); + if (!info.representable_p) + break; + bitmap_clear_range (bmp, regno + info.offset, info.nregs); + } + } + if (bitmap_empty_p (bmp)) + goto FALLTHRU; + } + else if (CALL_P (insn)) + EXECUTE_IF_SET_IN_BITMAP (bmp, 2, regno, iter) + if (call_used_or_fixed_reg_p (regno)) + break; + } + FAIL; +FALLTHRU:; }) (define_peephole2 diff --git a/gcc/configure b/gcc/configure index 39f7ed12..817d765 100755 --- a/gcc/configure +++ b/gcc/configure @@ -28144,6 +28144,41 @@ $as_echo "#define HAVE_AS_REF 1" >>confdefs.h fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking assembler for AIX DWARF location lists section support" >&5 +$as_echo_n "checking assembler for AIX DWARF location lists section support... " >&6; } +if ${gcc_cv_as_aix_dwloc+:} false; then : + $as_echo_n "(cached) " >&6 +else + gcc_cv_as_aix_dwloc=no + if test x$gcc_cv_as != x; then + $as_echo ' .dwsect 0xA0000 + Lframe..0: + .vbyte 4,Lframe..0 + ' > conftest.s + if { ac_try='$gcc_cv_as $gcc_cv_as_flags -o conftest.o conftest.s >&5' + { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_try\""; } >&5 + (eval $ac_try) 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; } + then + gcc_cv_as_aix_dwloc=yes + else + echo "configure: failed program was" >&5 + cat conftest.s >&5 + fi + rm -f conftest.o conftest.s + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $gcc_cv_as_aix_dwloc" >&5 +$as_echo "$gcc_cv_as_aix_dwloc" >&6; } +if test $gcc_cv_as_aix_dwloc = yes; then + +$as_echo "#define HAVE_XCOFF_DWARF_EXTRAS 1" >>confdefs.h + +fi + ;; esac ;; diff --git a/gcc/configure.ac b/gcc/configure.ac index 50bb61c..59f205a1 100644 --- a/gcc/configure.ac +++ b/gcc/configure.ac @@ -5066,6 +5066,15 @@ LCF0: ],, [AC_DEFINE(HAVE_AS_REF, 1, [Define if your assembler supports .ref])]) + + gcc_GAS_CHECK_FEATURE([AIX DWARF location lists section support], + gcc_cv_as_aix_dwloc,, + [ .dwsect 0xA0000 + Lframe..0: + .vbyte 4,Lframe..0 + ],, + [AC_DEFINE(HAVE_XCOFF_DWARF_EXTRAS, 1, + [Define if your assembler supports AIX debug frame section label reference.])]) ;; esac ;; diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index a11675e..0f37423 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,54 @@ +2022-09-08 Jonathan Wakely <jwakely@redhat.com> + + PR c++/106838 + * class.cc (type_has_virtual_destructor): Return false for + union types. + * semantics.cc (check_trait_type): Add KIND parameter to support + different sets of requirements. + (finish_trait_expr): Pass KIND argument for relevant traits. + +2022-09-08 Patrick Palka <ppalka@redhat.com> + + PR c++/99130 + * decl2.cc (maybe_instantiate_decl): Adjust function comment. + Check VAR_OR_FUNCTION_DECL_P. Pull out the disjunction into ... + (mark_used): ... here, removing the decl_maybe_constant_var_p + part of it. + +2022-09-07 Jason Merrill <jason@redhat.com> + + PR c++/106793 + * decl.cc (grokdeclarator): Improve placeholder diagnostics. + * parser.cc (cp_parser_type_id_1): Add fixit. + +2022-09-07 Arsen Arsenović <arsen@aarsen.me> + + PR c++/106188 + PR c++/106713 + * coroutines.cc (coro_rewrite_function_body): Ensure we have a + BIND_EXPR wrapping the function body. + +2022-09-07 Jakub Jelinek <jakub@redhat.com> + + PR c++/106829 + * semantics.cc (finish_omp_target_clauses): If current_function_decl + isn't a nonstatic member function, don't set data.current_object to + non-NULL. + +2022-09-06 Jason Merrill <jason@redhat.com> + + * decl.cc (grok_op_properties): Return sooner for C++23 op[]. + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + * parser.cc (cp_parser_omp_clause_doacross_sink): Don't verify val + in omp_cur_iteration - 1 has integer_type_node type. + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + * pt.cc (tsubst_expr) <case OMP_ORDERED>: If OMP_BODY was NULL, keep + it NULL after instantiation too. + 2022-09-03 Jakub Jelinek <jakub@redhat.com> * parser.cc (cp_parser_omp_clause_name): Handle doacross. diff --git a/gcc/cp/class.cc b/gcc/cp/class.cc index a12d367..b84f422 100644 --- a/gcc/cp/class.cc +++ b/gcc/cp/class.cc @@ -5620,7 +5620,7 @@ type_has_virtual_destructor (tree type) { tree dtor; - if (!CLASS_TYPE_P (type)) + if (!NON_UNION_CLASS_TYPE_P (type)) return false; gcc_assert (COMPLETE_TYPE_P (type)); diff --git a/gcc/cp/coroutines.cc b/gcc/cp/coroutines.cc index edb3b70..eca01ab 100644 --- a/gcc/cp/coroutines.cc +++ b/gcc/cp/coroutines.cc @@ -4095,6 +4095,15 @@ coro_rewrite_function_body (location_t fn_start, tree fnbody, tree orig, BLOCK_SUPERCONTEXT (replace_blk) = top_block; BLOCK_SUBBLOCKS (top_block) = replace_blk; } + else + { + /* We are missing a top level BIND_EXPR. We need one to ensure that we + don't shuffle around the coroutine frame and corrupt it. */ + tree bind_wrap = build3_loc (fn_start, BIND_EXPR, void_type_node, + NULL, NULL, NULL); + BIND_EXPR_BODY (bind_wrap) = fnbody; + fnbody = bind_wrap; + } /* Wrap the function body in a try {} catch (...) {} block, if exceptions are enabled. */ diff --git a/gcc/cp/decl.cc b/gcc/cp/decl.cc index b72b2a8..4665a29 100644 --- a/gcc/cp/decl.cc +++ b/gcc/cp/decl.cc @@ -12407,14 +12407,20 @@ grokdeclarator (const cp_declarator *declarator, if (cxx_dialect >= cxx17 && type && is_auto (type) && innermost_code != cdk_function + /* Placeholder in parm gets a better error below. */ + && !(decl_context == PARM || decl_context == CATCHPARM) && id_declarator && declarator != id_declarator) if (tree tmpl = CLASS_PLACEHOLDER_TEMPLATE (type)) - { - error_at (typespec_loc, "template placeholder type %qT must be followed " - "by a simple declarator-id", type); - inform (DECL_SOURCE_LOCATION (tmpl), "%qD declared here", tmpl); - type = error_mark_node; - } + { + auto_diagnostic_group g; + gcc_rich_location richloc (typespec_loc); + richloc.add_fixit_insert_after ("<>"); + error_at (&richloc, "missing template argument list after %qE; " + "for deduction, template placeholder must be followed " + "by a simple declarator-id", tmpl); + inform (DECL_SOURCE_LOCATION (tmpl), "%qD declared here", tmpl); + type = error_mark_node; + } staticp = 0; inlinep = decl_spec_seq_has_spec_p (declspecs, ds_inline); @@ -12892,6 +12898,7 @@ grokdeclarator (const cp_declarator *declarator, { if (!funcdecl_p || !dguide_name_p (unqualified_id)) { + auto_diagnostic_group g; error_at (typespec_loc, "deduced class " "type %qD in function return type", DECL_NAME (tmpl)); @@ -13837,12 +13844,15 @@ grokdeclarator (const cp_declarator *declarator, else if (tree c = CLASS_PLACEHOLDER_TEMPLATE (auto_node)) { auto_diagnostic_group g; - error_at (typespec_loc, - "class template placeholder %qE not permitted " - "in this context", c); + gcc_rich_location richloc (typespec_loc); + richloc.add_fixit_insert_after ("<>"); + error_at (&richloc, + "missing template argument list after %qE; template " + "placeholder not permitted in parameter", c); if (decl_context == PARM && cxx_dialect >= cxx20) - inform (typespec_loc, "use %<auto%> for an " + inform (typespec_loc, "or use %<auto%> for an " "abbreviated function template"); + inform (DECL_SOURCE_LOCATION (c), "%qD declared here", c); } else error_at (typespec_loc, @@ -15331,6 +15341,11 @@ grok_op_properties (tree decl, bool complain) "operator ()". */ return true; + /* C++23 allows an arbitrary number of parameters and default arguments for + operator[], and none of the other checks below apply. */ + if (operator_code == ARRAY_REF && cxx_dialect >= cxx23) + return true; + if (operator_code == COND_EXPR) { /* 13.4.0.3 */ @@ -15344,10 +15359,6 @@ grok_op_properties (tree decl, bool complain) { if (!arg) { - /* Variadic. */ - if (operator_code == ARRAY_REF && cxx_dialect >= cxx23) - break; - error_at (loc, "%qD must not have variable number of arguments", decl); return false; @@ -15408,8 +15419,6 @@ grok_op_properties (tree decl, bool complain) case OVL_OP_FLAG_BINARY: if (arity != 2) { - if (operator_code == ARRAY_REF && cxx_dialect >= cxx23) - break; error_at (loc, methodp ? G_("%qD must have exactly one argument") diff --git a/gcc/cp/decl2.cc b/gcc/cp/decl2.cc index 89ab254..cd18881 100644 --- a/gcc/cp/decl2.cc +++ b/gcc/cp/decl2.cc @@ -5381,24 +5381,15 @@ possibly_inlined_p (tree decl) return true; } -/* Normally, we can wait until instantiation-time to synthesize DECL. - However, if DECL is a static data member initialized with a constant - or a constexpr function, we need it right now because a reference to - such a data member or a call to such function is not value-dependent. - For a function that uses auto in the return type, we need to instantiate - it to find out its type. For OpenMP user defined reductions, we need - them instantiated for reduction clauses which inline them by hand - directly. */ +/* If DECL is a function or variable template specialization, instantiate + its definition now. */ void maybe_instantiate_decl (tree decl) { - if (DECL_LANG_SPECIFIC (decl) + if (VAR_OR_FUNCTION_DECL_P (decl) + && DECL_LANG_SPECIFIC (decl) && DECL_TEMPLATE_INFO (decl) - && (decl_maybe_constant_var_p (decl) - || (TREE_CODE (decl) == FUNCTION_DECL - && DECL_OMP_DECLARE_REDUCTION_P (decl)) - || undeduced_auto_decl (decl)) && !DECL_DECLARED_CONCEPT_P (decl) && !uses_template_parms (DECL_TI_ARGS (decl))) { @@ -5700,15 +5691,13 @@ mark_used (tree decl, tsubst_flags_t complain) return false; } - /* Normally, we can wait until instantiation-time to synthesize DECL. - However, if DECL is a static data member initialized with a constant - or a constexpr function, we need it right now because a reference to - such a data member or a call to such function is not value-dependent. - For a function that uses auto in the return type, we need to instantiate - it to find out its type. For OpenMP user defined reductions, we need - them instantiated for reduction clauses which inline them by hand - directly. */ - maybe_instantiate_decl (decl); + /* If DECL has a deduced return type, we need to instantiate it now to + find out its type. For OpenMP user defined reductions, we need them + instantiated for reduction clauses which inline them by hand directly. */ + if (undeduced_auto_decl (decl) + || (TREE_CODE (decl) == FUNCTION_DECL + && DECL_OMP_DECLARE_REDUCTION_P (decl))) + maybe_instantiate_decl (decl); if (processing_template_decl || in_template_function ()) return true; diff --git a/gcc/cp/parser.cc b/gcc/cp/parser.cc index 076ad62..841ba6e 100644 --- a/gcc/cp/parser.cc +++ b/gcc/cp/parser.cc @@ -24397,8 +24397,11 @@ cp_parser_type_id_1 (cp_parser *parser, cp_parser_flags flags, location_t loc = type_specifier_seq.locations[ds_type_spec]; if (tree tmpl = CLASS_PLACEHOLDER_TEMPLATE (auto_node)) { - error_at (loc, "missing template arguments after %qT", - auto_node); + auto_diagnostic_group g; + gcc_rich_location richloc (loc); + richloc.add_fixit_insert_after ("<>"); + error_at (&richloc, "missing template arguments after %qE", + tmpl); inform (DECL_SOURCE_LOCATION (tmpl), "%qD declared here", tmpl); } @@ -39355,8 +39358,7 @@ cp_parser_omp_clause_doacross_sink (cp_parser *parser, location_t clause_loc, && cp_lexer_nth_token_is (parser->lexer, 4, CPP_CLOSE_PAREN)) { tree val = cp_lexer_peek_nth_token (parser->lexer, 3)->u.value; - if (integer_onep (val) - && same_type_p (TREE_TYPE (val), integer_type_node)) + if (integer_onep (val)) { cp_lexer_consume_token (parser->lexer); cp_lexer_consume_token (parser->lexer); diff --git a/gcc/cp/pt.cc b/gcc/cp/pt.cc index cd0d892..c5fc0f1 100644 --- a/gcc/cp/pt.cc +++ b/gcc/cp/pt.cc @@ -19526,9 +19526,14 @@ tsubst_expr (tree t, tree args, tsubst_flags_t complain, tree in_decl, case OMP_ORDERED: tmp = tsubst_omp_clauses (OMP_ORDERED_CLAUSES (t), C_ORT_OMP, args, complain, in_decl); - stmt = push_stmt_list (); - RECUR (OMP_BODY (t)); - stmt = pop_stmt_list (stmt); + if (OMP_BODY (t)) + { + stmt = push_stmt_list (); + RECUR (OMP_BODY (t)); + stmt = pop_stmt_list (stmt); + } + else + stmt = NULL_TREE; t = copy_node (t); OMP_BODY (t) = stmt; diff --git a/gcc/cp/semantics.cc b/gcc/cp/semantics.cc index 7b2c495..6bda30e 100644 --- a/gcc/cp/semantics.cc +++ b/gcc/cp/semantics.cc @@ -9555,16 +9555,15 @@ finish_omp_target_clauses (location_t loc, tree body, tree *clauses_ptr) { omp_target_walk_data data; data.this_expr_accessed = false; + data.current_object = NULL_TREE; - tree ct = current_nonlambda_class_type (); - if (ct) - { - tree object = maybe_dummy_object (ct, NULL); - object = maybe_resolve_dummy (object, true); - data.current_object = object; - } - else - data.current_object = NULL_TREE; + if (DECL_NONSTATIC_MEMBER_P (current_function_decl) && current_class_ptr) + if (tree ct = current_nonlambda_class_type ()) + { + tree object = maybe_dummy_object (ct, NULL); + object = maybe_resolve_dummy (object, true); + data.current_object = object; + } if (DECL_LAMBDA_FUNCTION_P (current_function_decl)) { @@ -12029,11 +12028,23 @@ trait_expr_value (cp_trait_kind kind, tree type1, tree type2) } } -/* If TYPE is an array of unknown bound, or (possibly cv-qualified) - void, or a complete type, returns true, otherwise false. */ +/* Returns true if TYPE meets the requirements for the specified KIND, + false otherwise. + + When KIND == 1, TYPE must be an array of unknown bound, + or (possibly cv-qualified) void, or a complete type. + + When KIND == 2, TYPE must be a complete type, or array of complete type, + or (possibly cv-qualified) void. + + When KIND == 3: + If TYPE is a non-union class type, it must be complete. + + When KIND == 4: + If TYPE is a class type, it must be complete. */ static bool -check_trait_type (tree type) +check_trait_type (tree type, int kind = 1) { if (type == NULL_TREE) return true; @@ -12042,8 +12053,14 @@ check_trait_type (tree type) return (check_trait_type (TREE_VALUE (type)) && check_trait_type (TREE_CHAIN (type))); - if (TREE_CODE (type) == ARRAY_TYPE && !TYPE_DOMAIN (type)) - return true; + if (kind == 1 && TREE_CODE (type) == ARRAY_TYPE && !TYPE_DOMAIN (type)) + return true; // Array of unknown bound. Don't care about completeness. + + if (kind == 3 && !NON_UNION_CLASS_TYPE_P (type)) + return true; // Not a non-union class type. Don't care about completeness. + + if (kind == 4 && TREE_CODE (type) == ARRAY_TYPE) + return true; // Not a class type. Don't care about completeness. if (VOID_TYPE_P (type)) return true; @@ -12081,23 +12098,39 @@ finish_trait_expr (location_t loc, cp_trait_kind kind, tree type1, tree type2) case CPTK_HAS_TRIVIAL_COPY: case CPTK_HAS_TRIVIAL_DESTRUCTOR: case CPTK_HAS_UNIQUE_OBJ_REPRESENTATIONS: - case CPTK_HAS_VIRTUAL_DESTRUCTOR: - case CPTK_IS_ABSTRACT: - case CPTK_IS_AGGREGATE: - case CPTK_IS_EMPTY: - case CPTK_IS_FINAL: + if (!check_trait_type (type1)) + return error_mark_node; + break; + case CPTK_IS_LITERAL_TYPE: case CPTK_IS_POD: - case CPTK_IS_POLYMORPHIC: case CPTK_IS_STD_LAYOUT: case CPTK_IS_TRIVIAL: case CPTK_IS_TRIVIALLY_COPYABLE: - if (!check_trait_type (type1)) + if (!check_trait_type (type1, /* kind = */ 2)) + return error_mark_node; + break; + + case CPTK_IS_EMPTY: + case CPTK_IS_POLYMORPHIC: + case CPTK_IS_ABSTRACT: + case CPTK_HAS_VIRTUAL_DESTRUCTOR: + if (!check_trait_type (type1, /* kind = */ 3)) + return error_mark_node; + break; + + /* N.B. std::is_aggregate is kind=2 but we don't need a complete element + type to know whether an array is an aggregate, so use kind=4 here. */ + case CPTK_IS_AGGREGATE: + case CPTK_IS_FINAL: + if (!check_trait_type (type1, /* kind = */ 4)) return error_mark_node; break; case CPTK_IS_ASSIGNABLE: case CPTK_IS_CONSTRUCTIBLE: + if (!check_trait_type (type1)) + return error_mark_node; break; case CPTK_IS_TRIVIALLY_ASSIGNABLE: diff --git a/gcc/doc/extend.texi b/gcc/doc/extend.texi index d4d28f1..8a34690 100644 --- a/gcc/doc/extend.texi +++ b/gcc/doc/extend.texi @@ -25169,14 +25169,17 @@ Requires: @code{type} shall be a complete type, (possibly cv-qualified) @item __has_virtual_destructor (type) If @code{type} is a class type with a virtual destructor ([class.dtor]) then the trait is @code{true}, else it is @code{false}. -Requires: @code{type} shall be a complete type, (possibly cv-qualified) -@code{void}, or an array of unknown bound. +Requires: If @code{type} is a non-union class type, it shall be a complete type. @item __is_abstract (type) If @code{type} is an abstract class ([class.abstract]) then the trait is @code{true}, else it is @code{false}. -Requires: @code{type} shall be a complete type, (possibly cv-qualified) -@code{void}, or an array of unknown bound. +Requires: If @code{type} is a non-union class type, it shall be a complete type. + +@item __is_aggregate (type) +If @code{type} is an aggregate type ([dcl.init.aggr]) the trait is +@code{true}, else it is @code{false}. +Requires: If @code{type} is a class type, it shall be a complete type. @item __is_base_of (base_type, derived_type) If @code{base_type} is a base class of @code{derived_type} @@ -25201,13 +25204,17 @@ any, are bit-fields of length 0, and @code{type} has no virtual members, and @code{type} has no virtual base classes, and @code{type} has no base classes @code{base_type} for which @code{__is_empty (base_type)} is @code{false}. -Requires: @code{type} shall be a complete type, (possibly cv-qualified) -@code{void}, or an array of unknown bound. +Requires: If @code{type} is a non-union class type, it shall be a complete type. @item __is_enum (type) If @code{type} is a cv enumeration type ([basic.compound]) the trait is @code{true}, else it is @code{false}. +@item __is_final (type) +If @code{type} is a class or union type marked @code{final}, then the trait +is @code{true}, else it is @code{false}. +Requires: If @code{type} is a class type, it shall be a complete type. + @item __is_literal_type (type) If @code{type} is a literal type ([basic.types]) the trait is @code{true}, else it is @code{false}. @@ -25223,20 +25230,19 @@ Requires: @code{type} shall be a complete type, (possibly cv-qualified) @item __is_polymorphic (type) If @code{type} is a polymorphic class ([class.virtual]) then the trait is @code{true}, else it is @code{false}. -Requires: @code{type} shall be a complete type, (possibly cv-qualified) -@code{void}, or an array of unknown bound. +Requires: If @code{type} is a non-union class type, it shall be a complete type. @item __is_standard_layout (type) If @code{type} is a standard-layout type ([basic.types]) the trait is @code{true}, else it is @code{false}. -Requires: @code{type} shall be a complete type, (possibly cv-qualified) -@code{void}, or an array of unknown bound. +Requires: @code{type} shall be a complete type, an array of complete types, +or (possibly cv-qualified) @code{void}. @item __is_trivial (type) If @code{type} is a trivial type ([basic.types]) the trait is @code{true}, else it is @code{false}. -Requires: @code{type} shall be a complete type, (possibly cv-qualified) -@code{void}, or an array of unknown bound. +Requires: @code{type} shall be a complete type, an array of complete types, +or (possibly cv-qualified) @code{void}. @item __is_union (type) If @code{type} is a cv union type ([basic.compound]) the trait is diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index 9197964..a28d3a0 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -327,7 +327,7 @@ Objective-C and Objective-C++ Dialects}. -Winfinite-recursion @gol -Winit-self -Winline -Wno-int-conversion -Wint-in-bool-context @gol -Wno-int-to-pointer-cast -Wno-invalid-memory-model @gol --Winvalid-pch -Winvalid-utf8 -Wjump-misses-init @gol +-Winvalid-pch -Winvalid-utf8 -Wno-unicode -Wjump-misses-init @gol -Wlarger-than=@var{byte-size} -Wlogical-not-parentheses -Wlogical-op @gol -Wlong-long -Wno-lto-type-mismatch -Wmain -Wmaybe-uninitialized @gol -Wmemset-elt-size -Wmemset-transposed-args @gol @@ -409,6 +409,7 @@ Objective-C and Objective-C++ Dialects}. -Wno-analyzer-double-fclose @gol -Wno-analyzer-double-free @gol -Wno-analyzer-exposure-through-output-file @gol +-Wno-analyzer-exposure-through-uninit-copy @gol -Wno-analyzer-fd-access-mode-mismatch @gol -Wno-analyzer-fd-double-close @gol -Wno-analyzer-fd-leak @gol @@ -9540,6 +9541,12 @@ Warn if an invalid UTF-8 character is found. This warning is on by default for C++23 if @option{-finput-charset=UTF-8} is used and turned into error with @option{-pedantic-errors}. +@item -Wno-unicode +@opindex Wunicode +@opindex Wno-unicode +Don't diagnose invalid forms of delimited or named escape sequences which are +treated as separate tokens. @option{Wunicode} is enabled by default. + @item -Wlong-long @opindex Wlong-long @opindex Wno-long-long @@ -9753,6 +9760,7 @@ Enabling this option effectively enables the following warnings: -Wanalyzer-double-fclose @gol -Wanalyzer-double-free @gol -Wanalyzer-exposure-through-output-file @gol +-Wanalyzer-exposure-through-uninit-copy @gol -Wanalyzer-fd-access-mode-mismatch @gol -Wanalyzer-fd-double-close @gol -Wanalyzer-fd-leak @gol @@ -9855,6 +9863,20 @@ security-sensitive value is written to an output file See @uref{https://cwe.mitre.org/data/definitions/532.html, CWE-532: Information Exposure Through Log Files}. +@item Wanalyzer-exposure-through-uninit-copy +@opindex Wanalyzer-exposure-through-uninit-copy +@opindex Wno-analyzer-exposure-through-uninit-copy +This warning requires both @option{-fanalyzer} and the use of a plugin +to specify a function that copies across a ``trust boundary''. Use +@option{-Wno-analyzer-exposure-through-uninit-copy} to disable it. + +This diagnostic warns for ``infoleaks'' - paths through the code in which +uninitialized values are copied across a security boundary +(such as code within an OS kernel that copies a partially-initialized +struct on the stack to user space). + +See @uref{https://cwe.mitre.org/data/definitions/200.html, CWE-200: Exposure of Sensitive Information to an Unauthorized Actor}. + @item -Wno-analyzer-fd-access-mode-mismatch @opindex Wanalyzer-fd-access-mode-mismatch @opindex Wno-analyzer-fd-access-mode-mismatch @@ -10007,9 +10029,11 @@ This warning requires @option{-fanalyzer} to enable it; use @option{-Wno-analyzer-out-of-bounds} to disable it. This diagnostic warns for path through the code in which a buffer is -definitely read or written out-of-bounds. The diagnostic only applies -for cases where the analyzer is able to determine a constant offset and -for accesses past the end of a buffer, also a constant capacity. +definitely read or written out-of-bounds. The diagnostic applies for +cases where the analyzer is able to determine a constant offset and for +accesses past the end of a buffer, also a constant capacity. Further, +the diagnostic does limited checking for accesses past the end when the +offset as well as the capacity is symbolic. See @uref{https://cwe.mitre.org/data/definitions/119.html, CWE-119: Improper Restriction of Operations within the Bounds of a Memory Buffer}. diff --git a/gcc/doc/tm.texi b/gcc/doc/tm.texi index 66c2b7d..ff484b6 100644 --- a/gcc/doc/tm.texi +++ b/gcc/doc/tm.texi @@ -12942,7 +12942,8 @@ If defined, this macro is the number of entries in If defined, this macro is the name of a global variable containing target-specific format overrides for the @option{-Wformat} option. The default is to have no target-specific format overrides. If defined, -@code{TARGET_FORMAT_TYPES} must be defined, too. +@code{TARGET_FORMAT_TYPES} and @code{TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT} +must be defined, too. @end defmac @defmac TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT diff --git a/gcc/doc/tm.texi.in b/gcc/doc/tm.texi.in index 5312059..21b849e 100644 --- a/gcc/doc/tm.texi.in +++ b/gcc/doc/tm.texi.in @@ -7836,7 +7836,8 @@ If defined, this macro is the number of entries in If defined, this macro is the name of a global variable containing target-specific format overrides for the @option{-Wformat} option. The default is to have no target-specific format overrides. If defined, -@code{TARGET_FORMAT_TYPES} must be defined, too. +@code{TARGET_FORMAT_TYPES} and @code{TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT} +must be defined, too. @end defmac @defmac TARGET_OVERRIDES_FORMAT_ATTRIBUTES_COUNT diff --git a/gcc/dwarf2asm.cc b/gcc/dwarf2asm.cc index 7eac83f..274f574 100644 --- a/gcc/dwarf2asm.cc +++ b/gcc/dwarf2asm.cc @@ -35,6 +35,10 @@ along with GCC; see the file COPYING3. If not see #include "emit-rtl.h" #include "fold-const.h" +#ifndef XCOFF_DEBUGGING_INFO +#define XCOFF_DEBUGGING_INFO 0 +#endif + /* Output an unaligned integer with the given value and size. Prefer not to print a newline, since the caller may want to add a comment. */ @@ -380,13 +384,16 @@ dw2_asm_output_nstring (const char *str, size_t orig_len, if (flag_debug_asm && comment) { - fputs ("\t.ascii \"", asm_out_file); + if (XCOFF_DEBUGGING_INFO) + fputs ("\t.byte \"", asm_out_file); + else + fputs ("\t.ascii \"", asm_out_file); for (i = 0; i < len; i++) { int c = str[i]; if (c == '\"') - fputc ('\\', asm_out_file); + fputc (XCOFF_DEBUGGING_INFO ? '\"' : '\\', asm_out_file); else if (c == '\\') fputc ('\\', asm_out_file); if (ISPRINT (c)) @@ -906,7 +913,7 @@ static GTY(()) hash_map<const char *, tree> *indirect_pool; static GTY(()) int dw2_const_labelno; #if defined(HAVE_GAS_HIDDEN) -# define USE_LINKONCE_INDIRECT (SUPPORTS_ONE_ONLY) +# define USE_LINKONCE_INDIRECT (SUPPORTS_ONE_ONLY && !XCOFF_DEBUGGING_INFO) #else # define USE_LINKONCE_INDIRECT 0 #endif diff --git a/gcc/dwarf2out.cc b/gcc/dwarf2out.cc index e418360..2df7590 100644 --- a/gcc/dwarf2out.cc +++ b/gcc/dwarf2out.cc @@ -105,6 +105,14 @@ static rtx_insn *cached_next_real_insn; static void dwarf2out_decl (tree); static bool is_redundant_typedef (const_tree); +#ifndef XCOFF_DEBUGGING_INFO +#define XCOFF_DEBUGGING_INFO 0 +#endif + +#ifndef HAVE_XCOFF_DWARF_EXTRAS +#define HAVE_XCOFF_DWARF_EXTRAS 0 +#endif + #ifdef VMS_DEBUGGING_INFO int vms_file_stats_name (const char *, long long *, long *, char *, int *); @@ -600,11 +608,14 @@ output_fde (dw_fde_ref fde, bool for_eh, bool second, for_eh + j); ASM_GENERATE_INTERNAL_LABEL (l1, FDE_AFTER_SIZE_LABEL, for_eh + j); ASM_GENERATE_INTERNAL_LABEL (l2, FDE_END_LABEL, for_eh + j); - if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4 && !for_eh) - dw2_asm_output_data (4, 0xffffffff, "Initial length escape value" - " indicating 64-bit DWARF extension"); - dw2_asm_output_delta (for_eh ? 4 : dwarf_offset_size, l2, l1, - "FDE Length"); + if (!XCOFF_DEBUGGING_INFO || for_eh) + { + if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4 && !for_eh) + dw2_asm_output_data (4, 0xffffffff, "Initial length escape value" + " indicating 64-bit DWARF extension"); + dw2_asm_output_delta (for_eh ? 4 : dwarf_offset_size, l2, l1, + "FDE Length"); + } ASM_OUTPUT_LABEL (asm_out_file, l1); if (for_eh) @@ -801,11 +812,14 @@ output_call_frame_info (int for_eh) /* Output the CIE. */ ASM_GENERATE_INTERNAL_LABEL (l1, CIE_AFTER_SIZE_LABEL, for_eh); ASM_GENERATE_INTERNAL_LABEL (l2, CIE_END_LABEL, for_eh); - if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4 && !for_eh) - dw2_asm_output_data (4, 0xffffffff, - "Initial length escape value indicating 64-bit DWARF extension"); - dw2_asm_output_delta (for_eh ? 4 : dwarf_offset_size, l2, l1, - "Length of Common Information Entry"); + if (!XCOFF_DEBUGGING_INFO || for_eh) + { + if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4 && !for_eh) + dw2_asm_output_data (4, 0xffffffff, + "Initial length escape value indicating 64-bit DWARF extension"); + dw2_asm_output_delta (for_eh ? 4 : dwarf_offset_size, l2, l1, + "Length of Common Information Entry"); + } ASM_OUTPUT_LABEL (asm_out_file, l1); /* Now that the CIE pointer is PC-relative for EH, @@ -3665,7 +3679,8 @@ static GTY (()) vec<macinfo_entry, va_gc> *macinfo_table; /* True if .debug_macinfo or .debug_macros section is going to be emitted. */ #define have_macinfo \ - (debug_info_level >= DINFO_LEVEL_VERBOSE \ + ((!XCOFF_DEBUGGING_INFO || HAVE_XCOFF_DWARF_EXTRAS) \ + && debug_info_level >= DINFO_LEVEL_VERBOSE \ && !macinfo_table->is_empty ()) /* Vector of dies for which we should generate .debug_ranges info. */ @@ -4967,6 +4982,9 @@ add_AT_loc_list (dw_die_ref die, enum dwarf_attribute attr_kind, dw_loc_list_ref { dw_attr_node attr; + if (XCOFF_DEBUGGING_INFO && !HAVE_XCOFF_DWARF_EXTRAS) + return; + attr.dw_attr = attr_kind; attr.dw_attr_val.val_class = dw_val_class_loc_list; attr.dw_attr_val.val_entry = NULL; @@ -4990,6 +5008,9 @@ add_AT_view_list (dw_die_ref die, enum dwarf_attribute attr_kind) { dw_attr_node attr; + if (XCOFF_DEBUGGING_INFO && !HAVE_XCOFF_DWARF_EXTRAS) + return; + attr.dw_attr = attr_kind; attr.dw_attr_val.val_class = dw_val_class_view_list; attr.dw_attr_val.val_entry = NULL; @@ -11145,12 +11166,15 @@ output_dwarf_version () static void output_compilation_unit_header (enum dwarf_unit_type ut) { - if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) - dw2_asm_output_data (4, 0xffffffff, - "Initial length escape value indicating 64-bit DWARF extension"); - dw2_asm_output_data (dwarf_offset_size, - next_die_offset - DWARF_INITIAL_LENGTH_SIZE, - "Length of Compilation Unit Info"); + if (!XCOFF_DEBUGGING_INFO) + { + if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) + dw2_asm_output_data (4, 0xffffffff, + "Initial length escape value indicating 64-bit DWARF extension"); + dw2_asm_output_data (dwarf_offset_size, + next_die_offset - DWARF_INITIAL_LENGTH_SIZE, + "Length of Compilation Unit Info"); + } output_dwarf_version (); if (dwarf_version >= 5) @@ -11659,11 +11683,14 @@ output_pubnames (vec<pubname_entry, va_gc> *names) unsigned long pubnames_length = size_of_pubnames (names); pubname_entry *pub; - if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) - dw2_asm_output_data (4, 0xffffffff, - "Initial length escape value indicating 64-bit DWARF extension"); - dw2_asm_output_data (dwarf_offset_size, pubnames_length, - "Pub Info Length"); + if (!XCOFF_DEBUGGING_INFO) + { + if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) + dw2_asm_output_data (4, 0xffffffff, + "Initial length escape value indicating 64-bit DWARF extension"); + dw2_asm_output_data (dwarf_offset_size, pubnames_length, + "Pub Info Length"); + } /* Version number for pubnames/pubtypes is independent of dwarf version. */ dw2_asm_output_data (2, 2, "DWARF pubnames/pubtypes version"); @@ -11738,11 +11765,14 @@ output_aranges (void) unsigned i; unsigned long aranges_length = size_of_aranges (); - if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) - dw2_asm_output_data (4, 0xffffffff, - "Initial length escape value indicating 64-bit DWARF extension"); - dw2_asm_output_data (dwarf_offset_size, aranges_length, - "Length of Address Ranges Info"); + if (!XCOFF_DEBUGGING_INFO) + { + if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) + dw2_asm_output_data (4, 0xffffffff, + "Initial length escape value indicating 64-bit DWARF extension"); + dw2_asm_output_data (dwarf_offset_size, aranges_length, + "Length of Address Ranges Info"); + } /* Version number for aranges is still 2, even up to DWARF5. */ dw2_asm_output_data (2, 2, "DWARF aranges version"); @@ -13036,11 +13066,14 @@ output_line_info (bool prologue_only) ASM_GENERATE_INTERNAL_LABEL (p2, LN_PROLOG_END_LABEL, output_line_info_generation++); - if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) - dw2_asm_output_data (4, 0xffffffff, - "Initial length escape value indicating 64-bit DWARF extension"); - dw2_asm_output_delta (dwarf_offset_size, l2, l1, - "Length of Source Line Info"); + if (!XCOFF_DEBUGGING_INFO) + { + if (DWARF_INITIAL_LENGTH_SIZE - dwarf_offset_size == 4) + dw2_asm_output_data (4, 0xffffffff, + "Initial length escape value indicating 64-bit DWARF extension"); + dw2_asm_output_delta (dwarf_offset_size, l2, l1, + "Length of Source Line Info"); + } ASM_OUTPUT_LABEL (asm_out_file, l1); @@ -29111,6 +29144,8 @@ output_macinfo (const char *debug_line_label, bool early_lto_debug) /* AIX Assembler inserts the length, so adjust the reference to match the offset expected by debuggers. */ strcpy (dl_section_ref, debug_line_label); + if (XCOFF_DEBUGGING_INFO) + strcat (dl_section_ref, DWARF_INITIAL_LENGTH_SIZE_STR); /* For .debug_macro emit the section header. */ if (!dwarf_strict || dwarf_version >= 5) @@ -32315,6 +32350,8 @@ dwarf2out_finish (const char *filename) /* AIX Assembler inserts the length, so adjust the reference to match the offset expected by debuggers. */ strcpy (dl_section_ref, debug_line_section_label); + if (XCOFF_DEBUGGING_INFO) + strcat (dl_section_ref, DWARF_INITIAL_LENGTH_SIZE_STR); if (debug_info_level >= DINFO_LEVEL_TERSE) add_AT_lineptr (main_comp_unit_die, DW_AT_stmt_list, @@ -33030,6 +33067,8 @@ dwarf2out_early_finish (const char *filename) /* AIX Assembler inserts the length, so adjust the reference to match the offset expected by debuggers. */ strcpy (dl_section_ref, debug_line_section_label); + if (XCOFF_DEBUGGING_INFO) + strcat (dl_section_ref, DWARF_INITIAL_LENGTH_SIZE_STR); if (debug_info_level >= DINFO_LEVEL_TERSE) add_AT_lineptr (comp_unit_die (), DW_AT_stmt_list, dl_section_ref); diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e20d569..676f89f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2022-09-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/95644 + * f95-lang.cc (gfc_init_builtin_functions): Declare FMA + built-ins. + * mathbuiltins.def: Declare FMA built-ins. + * trans-intrinsic.cc (conv_intrinsic_ieee_fma): New function. + (conv_intrinsic_ieee_signbit): New function. + (gfc_build_intrinsic_lib_fndecls): Add cases for FMA and + SIGNBIT. + +2022-09-08 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/106670 + * scanner.cc (skip_fixed_omp_sentinel): Add -Wsurprising warning + for 'omx' sentinels with -fopenmp. + * invoke.texi (-Wsurprising): Document additional warning case. + +2022-09-06 Tobias Burnus <tobias@codesourcery.com> + + * openmp.cc (resolve_omp_clauses): Remove ordered/linear + check as it is handled now in the middle end. + 2022-09-05 Tobias Burnus <tobias@codesourcery.com> * dump-parse-tree.cc (show_omp_namelist, show_omp_clauses): Handle diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 10ac8a9..ff4bf80 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -1281,6 +1281,22 @@ gfc_init_builtin_functions (void) "__builtin_assume_aligned", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (long_double_type_node, long_double_type_node, + long_double_type_node, long_double_type_node, + NULL_TREE); + gfc_define_builtin ("__builtin_fmal", ftype, BUILT_IN_FMAL, + "fmal", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (double_type_node, double_type_node, + double_type_node, double_type_node, + NULL_TREE); + gfc_define_builtin ("__builtin_fma", ftype, BUILT_IN_FMA, + "fma", ATTR_CONST_NOTHROW_LEAF_LIST); + ftype = build_function_type_list (float_type_node, float_type_node, + float_type_node, float_type_node, + NULL_TREE); + gfc_define_builtin ("__builtin_fmaf", ftype, BUILT_IN_FMAF, + "fmaf", ATTR_CONST_NOTHROW_LEAF_LIST); + gfc_define_builtin ("__emutls_get_address", builtin_types[BT_FN_PTR_PTR], BUILT_IN_EMUTLS_GET_ADDRESS, diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 0d0343d..ee1bf6c 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -1060,6 +1060,11 @@ The type of a function result is declared more than once with the same type. If @item A @code{CHARACTER} variable is declared with negative length. + +@item +With @option{-fopenmp}, for fixed-form source code, when an @code{omx} +vendor-extension sentinel is encountered. (The equivalent @code{ompx}, +used in free-form source code, is diagnosed by default.) @end itemize @item -Wtabs diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def index 615214e..9d55c34 100644 --- a/gcc/fortran/mathbuiltins.def +++ b/gcc/fortran/mathbuiltins.def @@ -60,6 +60,7 @@ OTHER_BUILTIN (CABS, "cabs", cabs, true) OTHER_BUILTIN (COPYSIGN, "copysign", 2, true) OTHER_BUILTIN (CPOW, "cpow", cpow, true) OTHER_BUILTIN (FABS, "fabs", 1, true) +OTHER_BUILTIN (FMA, "fma", 3, true) OTHER_BUILTIN (FMOD, "fmod", 2, true) OTHER_BUILTIN (FREXP, "frexp", frexp, false) OTHER_BUILTIN (LOGB, "logb", 1, true) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 5142fd7..457e983 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -7625,10 +7625,6 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, linear_op = n->u.linear.op; } } - else if (omp_clauses->orderedc) - gfc_error ("LINEAR clause specified together with " - "ORDERED clause with argument at %L", - &n->where); else if (n->u.linear.op != OMP_LINEAR_REF && n->sym->ts.type != BT_INTEGER) gfc_error ("LINEAR variable %qs must be INTEGER " diff --git a/gcc/fortran/scanner.cc b/gcc/fortran/scanner.cc index 2dff251..fa1d9cb 100644 --- a/gcc/fortran/scanner.cc +++ b/gcc/fortran/scanner.cc @@ -982,8 +982,9 @@ static bool skip_fixed_omp_sentinel (locus *start) { gfc_char_t c; - if (((c = next_char ()) == 'm' || c == 'M') - && ((c = next_char ()) == 'p' || c == 'P')) + if ((c = next_char ()) != 'm' && c != 'M') + return false; + if ((c = next_char ()) == 'p' || c == 'P') { c = next_char (); if (c != '\n' @@ -1005,6 +1006,9 @@ skip_fixed_omp_sentinel (locus *start) } } } + else if (UNLIKELY (c == 'x' || c == 'X')) + gfc_warning_now (OPT_Wsurprising, + "Ignoring '!$omx' vendor-extension sentinel at %C"); return false; } diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index ec116ff..bb93802 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -695,7 +695,7 @@ gfc_build_intrinsic_lib_fndecls (void) C99-like library functions. For now, we only handle _Float128 q-suffixed or IEC 60559 f128-suffixed functions. */ - tree type, complex_type, func_1, func_2, func_cabs, func_frexp; + tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp; tree func_iround, func_lround, func_llround, func_scalbn, func_cpow; memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1)); @@ -715,6 +715,8 @@ gfc_build_intrinsic_lib_fndecls (void) type, NULL_TREE); /* type (*) (type, type) */ func_2 = build_function_type_list (type, type, type, NULL_TREE); + /* type (*) (type, type, type) */ + func_3 = build_function_type_list (type, type, type, type, NULL_TREE); /* type (*) (type, &int) */ func_frexp = build_function_type_list (type, @@ -9781,7 +9783,7 @@ conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray, } -/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE, +/* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE and IEEE_UNORDERED, which translate directly to GCC type-generic built-ins. */ @@ -9801,6 +9803,23 @@ conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr, } +/* Generate code for intrinsics IEEE_SIGNBIT. */ + +static void +conv_intrinsic_ieee_signbit (gfc_se * se, gfc_expr * expr) +{ + tree arg, signbit; + + conv_ieee_function_args (se, expr, &arg, 1); + signbit = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_SIGNBIT), + 1, arg); + signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + signbit, integer_zero_node); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), signbit); +} + + /* Generate code for IEEE_IS_NORMAL intrinsic: IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0) */ @@ -10207,6 +10226,30 @@ conv_intrinsic_ieee_value (gfc_se *se, gfc_expr *expr) } +/* Generate code for IEEE_FMA. */ + +static void +conv_intrinsic_ieee_fma (gfc_se * se, gfc_expr * expr) +{ + tree args[3], decl, call; + int argprec; + + conv_ieee_function_args (se, expr, args, 3); + + /* All three arguments should have the same type. */ + gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[1]))); + gcc_assert (TYPE_PRECISION (TREE_TYPE (args[0])) == TYPE_PRECISION (TREE_TYPE (args[2]))); + + /* Call the type-generic FMA built-in. */ + argprec = TYPE_PRECISION (TREE_TYPE (args[0])); + decl = builtin_decl_for_precision (BUILT_IN_FMA, argprec); + call = build_call_expr_loc_array (input_location, decl, 3, args); + + /* Convert to the final type. */ + se->expr = fold_convert (TREE_TYPE (args[0]), call); +} + + /* Generate code for an intrinsic function from the IEEE_ARITHMETIC module. */ @@ -10221,6 +10264,8 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr) conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1); else if (startswith (name, "_gfortran_ieee_unordered")) conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2); + else if (startswith (name, "_gfortran_ieee_signbit")) + conv_intrinsic_ieee_signbit (se, expr); else if (startswith (name, "_gfortran_ieee_is_normal")) conv_intrinsic_ieee_is_normal (se, expr); else if (startswith (name, "_gfortran_ieee_is_negative")) @@ -10241,6 +10286,8 @@ gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr) conv_intrinsic_ieee_class (se, expr); else if (startswith (name, "ieee_value_") && ISDIGIT (name[11])) conv_intrinsic_ieee_value (se, expr); + else if (startswith (name, "_gfortran_ieee_fma")) + conv_intrinsic_ieee_fma (se, expr); else /* It is not among the functions we translate directly. We return false, so a library function call is emitted. */ diff --git a/gcc/gimple-harden-conditionals.cc b/gcc/gimple-harden-conditionals.cc index 4ca6776..1b3dd56 100644 --- a/gcc/gimple-harden-conditionals.cc +++ b/gcc/gimple-harden-conditionals.cc @@ -238,6 +238,7 @@ insert_check_and_trap (location_t loc, gimple_stmt_iterator *gsip, gimple_stmt_iterator gsit = gsi_after_labels (trp); gcall *trap = gimple_build_call (builtin_decl_explicit (BUILT_IN_TRAP), 0); + gimple_call_set_ctrl_altering (trap, true); gimple_set_location (trap, loc); gsi_insert_before (&gsit, trap, GSI_SAME_STMT); diff --git a/gcc/gimple-predicate-analysis.cc b/gcc/gimple-predicate-analysis.cc index 681047d..bc9ed84 100644 --- a/gcc/gimple-predicate-analysis.cc +++ b/gcc/gimple-predicate-analysis.cc @@ -926,31 +926,35 @@ simple_control_dep_chain (vec<edge>& chain, basic_block from, basic_block to) { basic_block dest = src; src = get_immediate_dominator (CDI_DOMINATORS, src); - edge pred_e; - if (single_pred_p (dest) - && (pred_e = find_edge (src, dest))) - chain.safe_push (pred_e); + if (single_pred_p (dest)) + { + edge pred_e = single_pred_edge (dest); + gcc_assert (pred_e->src == src); + if (!(pred_e->flags & ((EDGE_FAKE | EDGE_ABNORMAL | EDGE_DFS_BACK))) + && !single_succ_p (src)) + chain.safe_push (pred_e); + } } } /* Perform a DFS walk on predecessor edges to mark the region denoted - by the EXIT edge and DOM which dominates EXIT->src, including DOM. + by the EXIT_SRC block and DOM which dominates EXIT_SRC, including DOM. Blocks in the region are marked with FLAG and added to BBS. BBS is filled up to its capacity only after which the walk is terminated and false is returned. If the whole region was marked, true is returned. */ static bool -dfs_mark_dominating_region (edge exit, basic_block dom, int flag, +dfs_mark_dominating_region (basic_block exit_src, basic_block dom, int flag, vec<basic_block> &bbs) { - if (exit->src == dom || exit->src->flags & flag) + if (exit_src == dom || exit_src->flags & flag) return true; if (!bbs.space (1)) return false; - bbs.quick_push (exit->src); - exit->src->flags |= flag; + bbs.quick_push (exit_src); + exit_src->flags |= flag; auto_vec<edge_iterator, 20> stack (bbs.allocated () - bbs.length () + 1); - stack.quick_push (ei_start (exit->src->preds)); + stack.quick_push (ei_start (exit_src->preds)); while (!stack.is_empty ()) { /* Look at the edge on the top of the stack. */ @@ -981,6 +985,97 @@ dfs_mark_dominating_region (edge exit, basic_block dom, int flag, return true; } +static bool +compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, + vec<edge> cd_chains[], unsigned *num_chains, + vec<edge> &cur_cd_chain, unsigned *num_calls, + unsigned in_region, unsigned depth, + bool *complete_p); + +/* Helper for compute_control_dep_chain that walks the post-dominator + chain from CD_BB up unto TARGET_BB looking for paths to DEP_BB. */ + +static bool +compute_control_dep_chain_pdom (basic_block cd_bb, const_basic_block dep_bb, + basic_block target_bb, + vec<edge> cd_chains[], unsigned *num_chains, + vec<edge> &cur_cd_chain, unsigned *num_calls, + unsigned in_region, unsigned depth, + bool *complete_p) +{ + bool found_cd_chain = false; + while (cd_bb != target_bb) + { + if (cd_bb == dep_bb) + { + /* Found a direct control dependence. */ + if (*num_chains < MAX_NUM_CHAINS) + { + if (DEBUG_PREDICATE_ANALYZER && dump_file) + fprintf (dump_file, "%*s pushing { %s }\n", + depth, "", format_edge_vec (cur_cd_chain).c_str ()); + cd_chains[*num_chains] = cur_cd_chain.copy (); + (*num_chains)++; + } + found_cd_chain = true; + /* Check path from next edge. */ + break; + } + + /* If the dominating region has been marked avoid walking outside. */ + if (in_region != 0 && !(cd_bb->flags & in_region)) + break; + + /* Count the number of steps we perform to limit compile-time. + This should cover both recursion and the post-dominator walk. */ + if (*num_calls > (unsigned)param_uninit_control_dep_attempts) + { + if (dump_file) + fprintf (dump_file, "param_uninit_control_dep_attempts " + "exceeded: %u\n", *num_calls); + *complete_p = false; + break; + } + ++*num_calls; + + /* Check if DEP_BB is indirectly control-dependent on DOM_BB. */ + if (!single_succ_p (cd_bb) + && compute_control_dep_chain (cd_bb, dep_bb, cd_chains, + num_chains, cur_cd_chain, + num_calls, in_region, depth + 1, + complete_p)) + { + found_cd_chain = true; + break; + } + + /* The post-dominator walk will reach a backedge only + from a forwarder, otherwise it should choose to exit + the SCC. */ + if (single_succ_p (cd_bb) + && single_succ_edge (cd_bb)->flags & EDGE_DFS_BACK) + break; + basic_block prev_cd_bb = cd_bb; + cd_bb = get_immediate_dominator (CDI_POST_DOMINATORS, cd_bb); + if (cd_bb == EXIT_BLOCK_PTR_FOR_FN (cfun)) + break; + /* Pick up conditions toward the post dominator such like + loop exit conditions. See gcc.dg/uninit-pred-11.c and + gcc.dg/unninit-pred-12.c and PR106754. */ + if (single_pred_p (cd_bb)) + { + edge e2 = single_pred_edge (cd_bb); + gcc_assert (e2->src == prev_cd_bb); + /* But avoid adding fallthru or abnormal edges. */ + if (!(e2->flags & (EDGE_FAKE | EDGE_ABNORMAL | EDGE_DFS_BACK)) + && !single_succ_p (prev_cd_bb)) + cur_cd_chain.safe_push (e2); + } + } + return found_cd_chain; +} + + /* Recursively compute the control dependence chains (paths of edges) from the dependent basic block, DEP_BB, up to the dominating basic block, DOM_BB (the head node of a chain should be dominated by it), @@ -990,13 +1085,16 @@ dfs_mark_dominating_region (edge exit, basic_block dom, int flag, *NUM_CALLS is the number of recursive calls to control unbounded recursion. Return true if the information is successfully computed, false if - there is no control dependence or not computed. */ + there is no control dependence or not computed. + *COMPLETE_P is set to false if we stopped walking due to limits. + In this case there might be missing chains. */ static bool compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, vec<edge> cd_chains[], unsigned *num_chains, vec<edge> &cur_cd_chain, unsigned *num_calls, - unsigned in_region = 0, unsigned depth = 0) + unsigned in_region, unsigned depth, + bool *complete_p) { /* In our recursive calls this doesn't happen. */ if (single_succ_p (dom_bb)) @@ -1009,6 +1107,7 @@ compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, if (dump_file) fprintf (dump_file, "MAX_CHAIN_LEN exceeded: %u\n", cur_chain_len); + *complete_p = false; return false; } @@ -1020,9 +1119,10 @@ compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, if (DEBUG_PREDICATE_ANALYZER && dump_file) fprintf (dump_file, - "%*s%s (dom_bb = %u, dep_bb = %u, cd_chains = { %s }, ...)\n", + "%*s%s (dom_bb = %u, dep_bb = %u, ..., " + "cur_cd_chain = { %s }, ...)\n", depth, "", __func__, dom_bb->index, dep_bb->index, - format_edge_vecs (cd_chains, *num_chains).c_str ()); + format_edge_vec (cur_cd_chain).c_str ()); bool found_cd_chain = false; @@ -1035,73 +1135,17 @@ compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, continue; basic_block cd_bb = e->dest; + unsigned pop_mark = cur_cd_chain.length (); cur_cd_chain.safe_push (e); - while (!dominated_by_p (CDI_POST_DOMINATORS, dom_bb, cd_bb) - /* We want to stop when the CFG merges back from the - branch in dom_bb. The post-dominance check alone - falls foul of the case of a loop exit test branch - where the path on the loop exit post-dominates - the branch block. - The following catches this but will not allow - exploring the post-dom path further. For the - outermost recursion this means we will fail to - reach dep_bb while for others it means at least - dropping the loop exit predicate from the path - which is problematic as it increases the domain - spanned by the resulting predicate. - See gcc.dg/uninit-pred-11.c for the first case - and PR106754 for the second. */ - || single_pred_p (cd_bb)) - { - if (cd_bb == dep_bb) - { - /* Found a direct control dependence. */ - if (*num_chains < MAX_NUM_CHAINS) - { - cd_chains[*num_chains] = cur_cd_chain.copy (); - (*num_chains)++; - } - found_cd_chain = true; - /* Check path from next edge. */ - break; - } - - /* If the dominating region has been marked avoid walking outside. */ - if (in_region != 0 && !(cd_bb->flags & in_region)) - break; - - /* Count the number of steps we perform to limit compile-time. - This should cover both recursion and the post-dominator walk. */ - if (*num_calls > (unsigned)param_uninit_control_dep_attempts) - { - if (dump_file) - fprintf (dump_file, "param_uninit_control_dep_attempts " - "exceeded: %u\n", *num_calls); - return false; - } - ++*num_calls; - - /* Check if DEP_BB is indirectly control-dependent on DOM_BB. */ - if (!single_succ_p (cd_bb) - && compute_control_dep_chain (cd_bb, dep_bb, cd_chains, - num_chains, cur_cd_chain, - num_calls, in_region, depth + 1)) - { - found_cd_chain = true; - break; - } - - /* The post-dominator walk will reach a backedge only - from a forwarder, otherwise it should choose to exit - the SCC. */ - if (single_succ_p (cd_bb) - && single_succ_edge (cd_bb)->flags & EDGE_DFS_BACK) - break; - cd_bb = get_immediate_dominator (CDI_POST_DOMINATORS, cd_bb); - if (cd_bb == EXIT_BLOCK_PTR_FOR_FN (cfun)) - break; - } - cur_cd_chain.pop (); + basic_block target_bb + = get_immediate_dominator (CDI_POST_DOMINATORS, dom_bb); + /* Walk the post-dominator chain up to the CFG merge. */ + found_cd_chain + |= compute_control_dep_chain_pdom (cd_bb, dep_bb, target_bb, + cd_chains, num_chains, + cur_cd_chain, num_calls, + in_region, depth, complete_p); + cur_cd_chain.truncate (pop_mark); gcc_assert (cur_cd_chain.length () == cur_chain_len); } @@ -1109,6 +1153,9 @@ compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, return found_cd_chain; } +/* Wrapper around the compute_control_dep_chain worker above. Returns + true when the collected set of chains in CD_CHAINS is complete. */ + static bool compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, vec<edge> cd_chains[], unsigned *num_chains, @@ -1117,8 +1164,12 @@ compute_control_dep_chain (basic_block dom_bb, const_basic_block dep_bb, auto_vec<edge, MAX_CHAIN_LEN + 1> cur_cd_chain; unsigned num_calls = 0; unsigned depth = 0; - return compute_control_dep_chain (dom_bb, dep_bb, cd_chains, num_chains, - cur_cd_chain, &num_calls, in_region, depth); + bool complete_p = true; + /* Walk the post-dominator chain. */ + compute_control_dep_chain_pdom (dom_bb, dep_bb, NULL, cd_chains, + num_chains, cur_cd_chain, &num_calls, + in_region, depth, &complete_p); + return complete_p; } /* Implemented simplifications: @@ -1888,6 +1939,10 @@ bool uninit_analysis::init_use_preds (predicate &use_preds, basic_block def_bb, basic_block use_bb) { + if (DEBUG_PREDICATE_ANALYZER && dump_file) + fprintf (dump_file, "init_use_preds (def_bb = %u, use_bb = %u)\n", + def_bb->index, use_bb->index); + gcc_assert (use_preds.is_empty () && dominated_by_p (CDI_DOMINATORS, use_bb, def_bb)); @@ -1912,6 +1967,10 @@ uninit_analysis::init_use_preds (predicate &use_preds, basic_block def_bb, } while (1); + auto_bb_flag in_region (cfun); + auto_vec<basic_block, 20> region (MIN (n_basic_blocks_for_fn (cfun), + param_uninit_control_dep_attempts)); + /* Set DEP_CHAINS to the set of edges between CD_ROOT and USE_BB. Each DEP_CHAINS element is a series of edges whose conditions are logical conjunctions. Together, the DEP_CHAINS vector is @@ -1919,16 +1978,23 @@ uninit_analysis::init_use_preds (predicate &use_preds, basic_block def_bb, unsigned num_chains = 0; auto_vec<edge> dep_chains[MAX_NUM_CHAINS]; - if (!compute_control_dep_chain (cd_root, use_bb, dep_chains, &num_chains)) + if (!dfs_mark_dominating_region (use_bb, cd_root, in_region, region) + || !compute_control_dep_chain (cd_root, use_bb, dep_chains, &num_chains, + in_region)) { - gcc_assert (num_chains == 0); + /* If the info in dep_chains is not complete we need to use a + conservative approximation for the use predicate. */ + if (DEBUG_PREDICATE_ANALYZER && dump_file) + fprintf (dump_file, "init_use_preds: dep_chain incomplete, using " + "conservative approximation\n"); + num_chains = 1; + dep_chains[0].truncate (0); simple_control_dep_chain (dep_chains[0], cd_root, use_bb); - num_chains++; } - if (DEBUG_PREDICATE_ANALYZER && dump_file) - fprintf (dump_file, "init_use_preds (def_bb = %u, use_bb = %u)\n", - def_bb->index, use_bb->index); + /* Unmark the region. */ + for (auto bb : region) + bb->flags &= ~in_region; /* From the set of edges computed above initialize *THIS as the OR condition under which the definition in DEF_BB is used in USE_BB. @@ -2012,7 +2078,8 @@ uninit_analysis::init_from_phi_def (gphi *phi) } } for (unsigned i = 0; i < nedges; i++) - if (!dfs_mark_dominating_region (def_edges[i], cd_root, in_region, region)) + if (!dfs_mark_dominating_region (def_edges[i]->src, cd_root, + in_region, region)) break; unsigned num_chains = 0; @@ -2021,13 +2088,18 @@ uninit_analysis::init_from_phi_def (gphi *phi) { edge e = def_edges[i]; unsigned prev_nc = num_chains; - compute_control_dep_chain (cd_root, e->src, dep_chains, - &num_chains, in_region); + bool complete_p = compute_control_dep_chain (cd_root, e->src, dep_chains, + &num_chains, in_region); /* Update the newly added chains with the phi operand edge. */ if (EDGE_COUNT (e->src->succs) > 1) { - if (prev_nc == num_chains && num_chains < MAX_NUM_CHAINS) + if (complete_p + && prev_nc == num_chains + && num_chains < MAX_NUM_CHAINS) + /* We can only add a chain for the PHI operand edge when the + collected info was complete, otherwise the predicate may + not be conservative. */ dep_chains[num_chains++] = vNULL; for (unsigned j = prev_nc; j < num_chains; j++) dep_chains[j].safe_push (e); @@ -2075,10 +2147,6 @@ uninit_analysis::is_use_guarded (gimple *use_stmt, basic_block use_bb, /* The basic block where the PHI is defined. */ basic_block def_bb = gimple_bb (phi); - if (dominated_by_p (CDI_POST_DOMINATORS, def_bb, use_bb)) - /* The use is not guarded. */ - return false; - /* Try to build the predicate expression under which the PHI flows into its use. This will be empty if the PHI is defined and used in the same bb. */ diff --git a/gcc/gimple-range-fold.cc b/gcc/gimple-range-fold.cc index c9c7a2c..85ed6f9 100644 --- a/gcc/gimple-range-fold.cc +++ b/gcc/gimple-range-fold.cc @@ -1029,15 +1029,16 @@ fold_using_range::range_of_builtin_int_call (irange &r, gcall *call, frange tmp; if (src.get_operand (tmp, arg)) { - if (tmp.get_signbit ().varying_p () - // FIXME: We don't support signed NANs yet. - || !tmp.get_nan ().no_p ()) - return false; - if (tmp.get_signbit ().yes_p ()) - r.set_nonzero (type); - else - r.set_zero (type); - return true; + bool signbit; + if (tmp.known_signbit (signbit)) + { + if (signbit) + r.set_nonzero (type); + else + r.set_zero (type); + return true; + } + return false; } break; } diff --git a/gcc/gimple.cc b/gcc/gimple.cc index cd5ad0c..4d45311 100644 --- a/gcc/gimple.cc +++ b/gcc/gimple.cc @@ -440,6 +440,7 @@ gimple_build_builtin_unreachable (location_t loc) gcc_checking_assert (data == NULL_TREE); g = gimple_build_call_internal (IFN_TRAP, 0); } + gimple_call_set_ctrl_altering (g, true); gimple_set_location (g, loc); return g; } diff --git a/gcc/gimple.h b/gcc/gimple.h index 1d15ff9..77ac149 100644 --- a/gcc/gimple.h +++ b/gcc/gimple.h @@ -194,6 +194,7 @@ enum gf_mask { GF_OMP_RETURN_NOWAIT = 1 << 0, GF_OMP_SECTION_LAST = 1 << 0, + GF_OMP_ORDERED_STANDALONE = 1 << 0, GF_OMP_ATOMIC_MEMORY_ORDER = (1 << 6) - 1, GF_OMP_ATOMIC_NEED_VALUE = 1 << 6, GF_OMP_ATOMIC_WEAK = 1 << 7, @@ -2312,7 +2313,7 @@ static inline unsigned gimple_omp_subcode (const gimple *s) { gcc_gimple_checking_assert (gimple_code (s) >= GIMPLE_OMP_ATOMIC_LOAD - && gimple_code (s) <= GIMPLE_OMP_TEAMS); + && gimple_code (s) <= GIMPLE_OMP_ORDERED); return s->subcode; } @@ -2402,6 +2403,27 @@ gimple_omp_section_set_last (gimple *g) } +/* Return true if OMP ordered construct is stand-alone + (G has the GF_OMP_ORDERED_STANDALONE flag set). */ + +static inline bool +gimple_omp_ordered_standalone_p (const gimple *g) +{ + GIMPLE_CHECK (g, GIMPLE_OMP_ORDERED); + return (gimple_omp_subcode (g) & GF_OMP_ORDERED_STANDALONE) != 0; +} + + +/* Set the GF_OMP_ORDERED_STANDALONE flag on G. */ + +static inline void +gimple_omp_ordered_standalone (gimple *g) +{ + GIMPLE_CHECK (g, GIMPLE_OMP_ORDERED); + g->subcode |= GF_OMP_ORDERED_STANDALONE; +} + + /* Return true if OMP parallel statement G has the GF_OMP_PARALLEL_COMBINED flag set. */ diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc index 988fc93..dcdc852 100644 --- a/gcc/gimplify.cc +++ b/gcc/gimplify.cc @@ -12427,7 +12427,7 @@ gimplify_omp_taskloop_expr (tree type, tree *tp, gimple_seq *pre_p, } /* Helper function of gimplify_omp_for, find OMP_ORDERED with - OMP_CLAUSE_DOACROSS clause inside of OMP_FOR's body. */ + null OMP_ORDERED_BODY inside of OMP_FOR's body. */ static tree find_standalone_omp_ordered (tree *tp, int *walk_subtrees, void *) @@ -12435,7 +12435,7 @@ find_standalone_omp_ordered (tree *tp, int *walk_subtrees, void *) switch (TREE_CODE (*tp)) { case OMP_ORDERED: - if (omp_find_clause (OMP_ORDERED_CLAUSES (*tp), OMP_CLAUSE_DOACROSS)) + if (OMP_ORDERED_BODY (*tp) == NULL_TREE) return *tp; break; case OMP_SIMD: @@ -15839,6 +15839,9 @@ gimplify_expr (tree *expr_p, gimple_seq *pre_p, gimple_seq *post_p, break; case OMP_ORDERED: g = gimplify_omp_ordered (*expr_p, body); + if (OMP_BODY (*expr_p) == NULL_TREE + && gimple_code (g) == GIMPLE_OMP_ORDERED) + gimple_omp_ordered_standalone (g); break; case OMP_MASKED: gimplify_scan_omp_clauses (&OMP_MASKED_CLAUSES (*expr_p), diff --git a/gcc/ginclude/stdalign.h b/gcc/ginclude/stdalign.h index b10cad1..6ed4243 100644 --- a/gcc/ginclude/stdalign.h +++ b/gcc/ginclude/stdalign.h @@ -26,7 +26,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #ifndef _STDALIGN_H #define _STDALIGN_H -#ifndef __cplusplus +#if (!defined __cplusplus \ + && !(defined __STDC_VERSION__ && __STDC_VERSION__ > 201710L)) #define alignas _Alignas #define alignof _Alignof diff --git a/gcc/ginclude/stdbool.h b/gcc/ginclude/stdbool.h index fe500d9..bcf7839 100644 --- a/gcc/ginclude/stdbool.h +++ b/gcc/ginclude/stdbool.h @@ -30,11 +30,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #ifndef __cplusplus -#define bool _Bool #if defined __STDC_VERSION__ && __STDC_VERSION__ > 201710L -#define true ((_Bool)+1u) -#define false ((_Bool)+0u) +/* bool, true and false are keywords. */ #else +#define bool _Bool #define true 1 #define false 0 #endif diff --git a/gcc/ginclude/stddef.h b/gcc/ginclude/stddef.h index 315ff78..3d29213 100644 --- a/gcc/ginclude/stddef.h +++ b/gcc/ginclude/stddef.h @@ -451,6 +451,10 @@ typedef struct { #endif #endif /* C23. */ +#if defined __STDC_VERSION__ && __STDC_VERSION__ > 201710L +#define unreachable() (__builtin_unreachable ()) +#endif + #endif /* _STDDEF_H was defined this time */ #endif /* !_STDDEF_H && !_STDDEF_H_ && !_ANSI_STDDEF_H && !__STDDEF_H__ diff --git a/gcc/go/gofrontend/MERGE b/gcc/go/gofrontend/MERGE index ca79704..dce38e7 100644 --- a/gcc/go/gofrontend/MERGE +++ b/gcc/go/gofrontend/MERGE @@ -1,4 +1,4 @@ -d53e8a0e94e34dc609e34dd5e404debda2640cfb +6543b7fc6da533eb976b37649a925e7fd5a521fa The first line of this file holds the git revision number of the last merge done from the gofrontend repository. diff --git a/gcc/omp-expand.cc b/gcc/omp-expand.cc index 55c513d..5cac8df 100644 --- a/gcc/omp-expand.cc +++ b/gcc/omp-expand.cc @@ -3287,7 +3287,8 @@ expand_omp_ordered_source (gimple_stmt_iterator *gsi, struct omp_for_data *fd, static void expand_omp_ordered_sink (gimple_stmt_iterator *gsi, struct omp_for_data *fd, - tree *counts, tree c, location_t loc) + tree *counts, tree c, location_t loc, + basic_block cont_bb) { auto_vec<tree, 10> args; enum built_in_function sink_ix @@ -3300,7 +3301,93 @@ expand_omp_ordered_sink (gimple_stmt_iterator *gsi, struct omp_for_data *fd, if (deps == NULL) { - sorry_at (loc, "%<doacross(sink:omp_cur_iteration-1)%> not supported yet"); + /* Handle doacross(sink: omp_cur_iteration - 1). */ + gsi_prev (&gsi2); + edge e1 = split_block (gsi_bb (gsi2), gsi_stmt (gsi2)); + edge e2 = split_block_after_labels (e1->dest); + gsi2 = gsi_after_labels (e1->dest); + *gsi = gsi_last_bb (e1->src); + gimple_stmt_iterator gsi3 = *gsi; + + if (counts[fd->collapse - 1]) + { + gcc_assert (fd->collapse == 1); + t = counts[fd->collapse - 1]; + } + else if (fd->collapse > 1) + t = fd->loop.v; + else + { + t = fold_build2 (MINUS_EXPR, TREE_TYPE (fd->loops[0].v), + fd->loops[0].v, fd->loops[0].n1); + t = fold_convert (fd->iter_type, t); + } + + t = force_gimple_operand_gsi (gsi, t, true, NULL_TREE, + false, GSI_CONTINUE_LINKING); + gsi_insert_after (gsi, gimple_build_cond (NE_EXPR, t, + build_zero_cst (TREE_TYPE (t)), + NULL_TREE, NULL_TREE), + GSI_NEW_STMT); + + t = fold_build2 (PLUS_EXPR, TREE_TYPE (t), t, + build_minus_one_cst (TREE_TYPE (t))); + t = force_gimple_operand_gsi (&gsi2, t, true, NULL_TREE, + true, GSI_SAME_STMT); + args.safe_push (t); + for (i = fd->collapse; i < fd->ordered; i++) + { + t = counts[fd->ordered + 2 + (i - fd->collapse)]; + t = fold_build2 (PLUS_EXPR, TREE_TYPE (t), t, + build_minus_one_cst (TREE_TYPE (t))); + t = fold_convert (fd->iter_type, t); + t = force_gimple_operand_gsi (&gsi2, t, true, NULL_TREE, + true, GSI_SAME_STMT); + args.safe_push (t); + } + + gimple *g = gimple_build_call_vec (builtin_decl_explicit (sink_ix), + args); + gimple_set_location (g, loc); + gsi_insert_before (&gsi2, g, GSI_SAME_STMT); + + edge e3 = make_edge (e1->src, e2->dest, EDGE_FALSE_VALUE); + e3->probability = profile_probability::guessed_always () / 8; + e1->probability = e3->probability.invert (); + e1->flags = EDGE_TRUE_VALUE; + set_immediate_dominator (CDI_DOMINATORS, e2->dest, e1->src); + + if (fd->ordered > fd->collapse && cont_bb) + { + if (counts[fd->ordered + 1] == NULL_TREE) + counts[fd->ordered + 1] + = create_tmp_var (boolean_type_node, ".first"); + + edge e4; + if (gsi_end_p (gsi3)) + e4 = split_block_after_labels (e1->src); + else + { + gsi_prev (&gsi3); + e4 = split_block (gsi_bb (gsi3), gsi_stmt (gsi3)); + } + gsi3 = gsi_last_bb (e4->src); + + gsi_insert_after (&gsi3, + gimple_build_cond (NE_EXPR, + counts[fd->ordered + 1], + boolean_false_node, + NULL_TREE, NULL_TREE), + GSI_NEW_STMT); + + edge e5 = make_edge (e4->src, e2->dest, EDGE_FALSE_VALUE); + e4->probability = profile_probability::guessed_always () / 8; + e5->probability = e4->probability.invert (); + e4->flags = EDGE_TRUE_VALUE; + set_immediate_dominator (CDI_DOMINATORS, e2->dest, e4->src); + } + + *gsi = gsi_after_labels (e2->dest); return; } for (i = 0; i < fd->ordered; i++) @@ -3558,6 +3645,7 @@ expand_omp_ordered_source_sink (struct omp_region *region, = build_array_type_nelts (fd->iter_type, fd->ordered - fd->collapse + 1); counts[fd->ordered] = create_tmp_var (atype, ".orditera"); TREE_ADDRESSABLE (counts[fd->ordered]) = 1; + counts[fd->ordered + 1] = NULL_TREE; for (inner = region->inner; inner; inner = inner->next) if (inner->type == GIMPLE_OMP_ORDERED) @@ -3575,7 +3663,7 @@ expand_omp_ordered_source_sink (struct omp_region *region, for (c = gimple_omp_ordered_clauses (ord_stmt); c; c = OMP_CLAUSE_CHAIN (c)) if (OMP_CLAUSE_DOACROSS_KIND (c) == OMP_CLAUSE_DOACROSS_SINK) - expand_omp_ordered_sink (&gsi, fd, counts, c, loc); + expand_omp_ordered_sink (&gsi, fd, counts, c, loc, cont_bb); gsi_remove (&gsi, true); } } @@ -3611,6 +3699,9 @@ expand_omp_for_ordered_loops (struct omp_for_data *fd, tree *counts, { tree t, type = TREE_TYPE (fd->loops[i].v); gimple_stmt_iterator gsi = gsi_after_labels (body_bb); + if (counts[fd->ordered + 1] && i == fd->collapse) + expand_omp_build_assign (&gsi, counts[fd->ordered + 1], + boolean_true_node); expand_omp_build_assign (&gsi, fd->loops[i].v, fold_convert (type, fd->loops[i].n1)); if (counts[i]) @@ -3658,6 +3749,9 @@ expand_omp_for_ordered_loops (struct omp_for_data *fd, tree *counts, size_int (i - fd->collapse + 1), NULL_TREE, NULL_TREE); expand_omp_build_assign (&gsi, aref, t); + if (counts[fd->ordered + 1] && i == fd->ordered - 1) + expand_omp_build_assign (&gsi, counts[fd->ordered + 1], + boolean_false_node); gsi_prev (&gsi); e2 = split_block (cont_bb, gsi_stmt (gsi)); new_header = e2->dest; @@ -3915,7 +4009,10 @@ expand_omp_for_generic (struct omp_region *region, int first_zero_iter1 = -1, first_zero_iter2 = -1; basic_block zero_iter1_bb = NULL, zero_iter2_bb = NULL, l2_dom_bb = NULL; - counts = XALLOCAVEC (tree, fd->ordered ? fd->ordered + 1 : fd->collapse); + counts = XALLOCAVEC (tree, fd->ordered + ? fd->ordered + 2 + + (fd->ordered - fd->collapse) + : fd->collapse); expand_omp_for_init_counts (fd, &gsi, entry_bb, counts, zero_iter1_bb, first_zero_iter1, zero_iter2_bb, first_zero_iter2, l2_dom_bb); @@ -4352,13 +4449,21 @@ expand_omp_for_generic (struct omp_region *region, if (fd->ordered) { /* Until now, counts array contained number of iterations or - variable containing it for ith loop. From now on, we need + variable containing it for ith loop. From now on, we usually need those counts only for collapsed loops, and only for the 2nd till the last collapsed one. Move those one element earlier, we'll use counts[fd->collapse - 1] for the first source/sink iteration counter and so on and counts[fd->ordered] as the array holding the current counter values for - depend(source). */ + depend(source). For doacross(sink:omp_cur_iteration - 1) we need + the counts from fd->collapse to fd->ordered - 1; make a copy of + those to counts[fd->ordered + 2] and onwards. + counts[fd->ordered + 1] can be a flag whether it is the first + iteration with a new collapsed counter (used only if + fd->ordered > fd->collapse). */ + if (fd->ordered > fd->collapse) + memcpy (counts + fd->ordered + 2, counts + fd->collapse, + (fd->ordered - fd->collapse) * sizeof (counts[0])); if (fd->collapse > 1) memmove (counts, counts + 1, (fd->collapse - 1) * sizeof (counts[0])); if (broken_loop) @@ -10487,8 +10592,7 @@ expand_omp (struct omp_region *region) { gomp_ordered *ord_stmt = as_a <gomp_ordered *> (last_stmt (region->entry)); - if (omp_find_clause (gimple_omp_ordered_clauses (ord_stmt), - OMP_CLAUSE_DOACROSS)) + if (gimple_omp_ordered_standalone_p (ord_stmt)) { /* We'll expand these when expanding corresponding worksharing region with ordered(n) clause. */ @@ -10616,9 +10720,7 @@ build_omp_regions_1 (basic_block bb, struct omp_region *parent, } } else if (code == GIMPLE_OMP_ORDERED - && omp_find_clause (gimple_omp_ordered_clauses - (as_a <gomp_ordered *> (stmt)), - OMP_CLAUSE_DOACROSS)) + && gimple_omp_ordered_standalone_p (stmt)) /* #pragma omp ordered depend is also just a stand-alone directive. */ region = NULL; @@ -10842,9 +10944,7 @@ omp_make_gimple_edges (basic_block bb, struct omp_region **region, case GIMPLE_OMP_ORDERED: cur_region = new_omp_region (bb, code, cur_region); fallthru = true; - if (omp_find_clause (gimple_omp_ordered_clauses - (as_a <gomp_ordered *> (last)), - OMP_CLAUSE_DOACROSS)) + if (gimple_omp_ordered_standalone_p (last)) cur_region = cur_region->outer; break; diff --git a/gcc/omp-low.cc b/gcc/omp-low.cc index b32336b..fd0ccd5 100644 --- a/gcc/omp-low.cc +++ b/gcc/omp-low.cc @@ -3718,7 +3718,7 @@ check_omp_nesting_restrictions (gimple *stmt, omp_context *ctx) "a loop region with an %<ordered%> clause"); return false; } - if (omp_find_clause (c, OMP_CLAUSE_DOACROSS) == NULL_TREE) + if (!gimple_omp_ordered_standalone_p (stmt)) { if (OMP_CLAUSE_ORDERED_DOACROSS (o)) { @@ -9989,8 +9989,7 @@ lower_omp_ordered (gimple_stmt_iterator *gsi_p, omp_context *ctx) bool threads = omp_find_clause (gimple_omp_ordered_clauses (ord_stmt), OMP_CLAUSE_THREADS); - if (omp_find_clause (gimple_omp_ordered_clauses (ord_stmt), - OMP_CLAUSE_DOACROSS)) + if (gimple_omp_ordered_standalone_p (ord_stmt)) { /* FIXME: This is needs to be moved to the expansion to verify various conditions only testable on cfg with dominators computed, and also diff --git a/gcc/optc-save-gen.awk b/gcc/optc-save-gen.awk index 233d1fb..49065ce 100644 --- a/gcc/optc-save-gen.awk +++ b/gcc/optc-save-gen.awk @@ -1093,8 +1093,7 @@ for (i = 0; i < n_target_array; i++) { name = var_target_array[i] size = var_target_array_size[i] type = var_target_array_type[i] - print " if (ptr1->" name" != ptr2->" name ""; - print " || memcmp (ptr1->" name ", ptr2->" name ", " size " * sizeof(" type ")))" + print " if (memcmp (ptr1->" name ", ptr2->" name ", " size " * sizeof(" type ")))" print " return false;"; } for (i = 0; i < n_target_val; i++) { diff --git a/gcc/range-op-float.cc b/gcc/range-op-float.cc index 050f07a..0f928b6 100644 --- a/gcc/range-op-float.cc +++ b/gcc/range-op-float.cc @@ -167,7 +167,7 @@ frange_set_nan (frange &r, tree type) static inline bool finite_operand_p (const frange &op1) { - return flag_finite_math_only || op1.get_nan ().no_p (); + return flag_finite_math_only || !op1.maybe_nan (); } // Return TRUE if OP1 and OP2 are known to be free of NANs. @@ -175,9 +175,7 @@ finite_operand_p (const frange &op1) static inline bool finite_operands_p (const frange &op1, const frange &op2) { - return (flag_finite_math_only - || (op1.get_nan ().no_p () - && op2.get_nan ().no_p ())); + return flag_finite_math_only || (!op1.maybe_nan () && !op2.maybe_nan ()); } // Floating version of relop_early_resolve that takes into account NAN @@ -224,36 +222,79 @@ frange_drop_ninf (frange &r, tree type) // (X <= VAL) produces the range of [-INF, VAL]. -static void +static bool build_le (frange &r, tree type, const REAL_VALUE_TYPE &val) { + if (real_isnan (&val)) + { + r.set_undefined (); + return false; + } r.set (type, dconstninf, val); + return true; } // (X < VAL) produces the range of [-INF, VAL). -static void +static bool build_lt (frange &r, tree type, const REAL_VALUE_TYPE &val) { + if (real_isnan (&val)) + { + r.set_undefined (); + return false; + } + // < -INF is outside the range. + if (real_isinf (&val, 1)) + { + if (HONOR_NANS (type)) + frange_set_nan (r, type); + else + r.set_undefined (); + return false; + } // Hijack LE because we only support closed intervals. build_le (r, type, val); + return true; } // (X >= VAL) produces the range of [VAL, +INF]. -static void +static bool build_ge (frange &r, tree type, const REAL_VALUE_TYPE &val) { + if (real_isnan (&val)) + { + r.set_undefined (); + return false; + } r.set (type, val, dconstinf); + return true; } // (X > VAL) produces the range of (VAL, +INF]. -static void +static bool build_gt (frange &r, tree type, const REAL_VALUE_TYPE &val) { + if (real_isnan (&val)) + { + r.set_undefined (); + return false; + } + // > +INF is outside the range. + if (real_isinf (&val, 0)) + { + if (HONOR_NANS (type)) + frange_set_nan (r, type); + else + r.set_undefined (); + return false; + } + // Hijack GE because we only support closed intervals. build_ge (r, type, val); + return true; } @@ -503,7 +544,7 @@ foperator_lt::fold_range (irange &r, tree type, else r = range_true_and_false (type); } - else if (op1.get_nan ().yes_p () || op2.get_nan ().yes_p ()) + else if (op1.known_nan () || op2.known_nan ()) r = range_false (type); else r = range_true_and_false (type); @@ -520,10 +561,12 @@ foperator_lt::op1_range (frange &r, switch (get_bool_state (r, lhs, type)) { case BRS_TRUE: - build_lt (r, type, op2.upper_bound ()); - r.set_nan (fp_prop::NO); - // x < y implies x is not +INF. - frange_drop_inf (r, type); + if (build_lt (r, type, op2.upper_bound ())) + { + r.set_nan (fp_prop::NO); + // x < y implies x is not +INF. + frange_drop_inf (r, type); + } break; case BRS_FALSE: @@ -546,10 +589,12 @@ foperator_lt::op2_range (frange &r, switch (get_bool_state (r, lhs, type)) { case BRS_TRUE: - build_gt (r, type, op1.lower_bound ()); - r.set_nan (fp_prop::NO); - // x < y implies y is not -INF. - frange_drop_ninf (r, type); + if (build_gt (r, type, op1.lower_bound ())) + { + r.set_nan (fp_prop::NO); + // x < y implies y is not -INF. + frange_drop_ninf (r, type); + } break; case BRS_FALSE: @@ -601,7 +646,7 @@ foperator_le::fold_range (irange &r, tree type, else r = range_true_and_false (type); } - else if (op1.get_nan ().yes_p () || op2.get_nan ().yes_p ()) + else if (op1.known_nan () || op2.known_nan ()) r = range_false (type); else r = range_true_and_false (type); @@ -618,8 +663,8 @@ foperator_le::op1_range (frange &r, switch (get_bool_state (r, lhs, type)) { case BRS_TRUE: - build_le (r, type, op2.upper_bound ()); - r.set_nan (fp_prop::NO); + if (build_le (r, type, op2.upper_bound ())) + r.set_nan (fp_prop::NO); break; case BRS_FALSE: @@ -642,8 +687,8 @@ foperator_le::op2_range (frange &r, switch (get_bool_state (r, lhs, type)) { case BRS_TRUE: - build_ge (r, type, op1.lower_bound ()); - r.set_nan (fp_prop::NO); + if (build_ge (r, type, op1.lower_bound ())) + r.set_nan (fp_prop::NO); break; case BRS_FALSE: @@ -695,7 +740,7 @@ foperator_gt::fold_range (irange &r, tree type, else r = range_true_and_false (type); } - else if (op1.get_nan ().yes_p () || op2.get_nan ().yes_p ()) + else if (op1.known_nan () || op2.known_nan ()) r = range_false (type); else r = range_true_and_false (type); @@ -712,10 +757,12 @@ foperator_gt::op1_range (frange &r, switch (get_bool_state (r, lhs, type)) { case BRS_TRUE: - build_gt (r, type, op2.lower_bound ()); - r.set_nan (fp_prop::NO); - // x > y implies x is not -INF. - frange_drop_ninf (r, type); + if (build_gt (r, type, op2.lower_bound ())) + { + r.set_nan (fp_prop::NO); + // x > y implies x is not -INF. + frange_drop_ninf (r, type); + } break; case BRS_FALSE: @@ -738,10 +785,12 @@ foperator_gt::op2_range (frange &r, switch (get_bool_state (r, lhs, type)) { case BRS_TRUE: - build_lt (r, type, op1.upper_bound ()); - r.set_nan (fp_prop::NO); - // x > y implies y is not +INF. - frange_drop_inf (r, type); + if (build_lt (r, type, op1.upper_bound ())) + { + r.set_nan (fp_prop::NO); + // x > y implies y is not +INF. + frange_drop_inf (r, type); + } break; case BRS_FALSE: @@ -793,7 +842,7 @@ foperator_ge::fold_range (irange &r, tree type, else r = range_true_and_false (type); } - else if (op1.get_nan ().yes_p () || op2.get_nan ().yes_p ()) + else if (op1.known_nan () || op2.known_nan ()) r = range_false (type); else r = range_true_and_false (type); @@ -876,10 +925,10 @@ foperator_unordered::fold_range (irange &r, tree type, relation_kind) const { // UNORDERED is TRUE if either operand is a NAN. - if (op1.get_nan ().yes_p () || op2.get_nan ().yes_p ()) + if (op1.known_nan () || op2.known_nan ()) r = range_true (type); // UNORDERED is FALSE if neither operand is a NAN. - else if (op1.get_nan ().no_p () && op2.get_nan ().no_p ()) + else if (!op1.maybe_nan () && !op2.maybe_nan ()) r = range_false (type); else r = range_true_and_false (type); @@ -898,7 +947,7 @@ foperator_unordered::op1_range (frange &r, tree type, r.set_varying (type); // Since at least one operand must be NAN, if one of them is // not, the other must be. - if (op2.get_nan ().no_p ()) + if (!op2.maybe_nan ()) frange_set_nan (r, type); break; @@ -942,11 +991,9 @@ foperator_ordered::fold_range (irange &r, tree type, const frange &op1, const frange &op2, relation_kind) const { - // ORDERED is TRUE if neither operand is a NAN. - if (op1.get_nan ().no_p () && op2.get_nan ().no_p ()) + if (!op1.maybe_nan () && !op2.maybe_nan ()) r = range_true (type); - // ORDERED is FALSE if either operand is a NAN. - else if (op1.get_nan ().yes_p () || op2.get_nan ().yes_p ()) + else if (op1.known_nan () || op2.known_nan ()) r = range_false (type); else r = range_true_and_false (type); diff --git a/gcc/sched-rgn.cc b/gcc/sched-rgn.cc index 0dc2a8f..420c45d 100644 --- a/gcc/sched-rgn.cc +++ b/gcc/sched-rgn.cc @@ -3082,6 +3082,27 @@ free_bb_state_array (void) bb_state = NULL; } +/* If LAST_BB falls through to another block B, record that B should + start with DFA start STATE. */ + +static void +save_state_for_fallthru_edge (basic_block last_bb, state_t state) +{ + edge f = find_fallthru_edge (last_bb->succs); + if (f + && (!f->probability.initialized_p () + || (f->probability.to_reg_br_prob_base () * 100 + / REG_BR_PROB_BASE + >= param_sched_state_edge_prob_cutoff))) + { + memcpy (bb_state[f->dest->index], state, + dfa_state_size); + if (sched_verbose >= 5) + fprintf (sched_dump, "saving state for edge %d->%d\n", + f->src->index, f->dest->index); + } +} + /* Schedule a region. A region is either an inner loop, a loop-free subroutine, or a single basic block. Each bb in the region is scheduled after its flow predecessors. */ @@ -3155,6 +3176,7 @@ schedule_region (int rgn) if (no_real_insns_p (head, tail)) { gcc_assert (first_bb == last_bb); + save_state_for_fallthru_edge (last_bb, bb_state[first_bb->index]); continue; } @@ -3173,26 +3195,13 @@ schedule_region (int rgn) curr_bb = first_bb; if (dbg_cnt (sched_block)) { - edge f; int saved_last_basic_block = last_basic_block_for_fn (cfun); schedule_block (&curr_bb, bb_state[first_bb->index]); gcc_assert (EBB_FIRST_BB (bb) == first_bb); sched_rgn_n_insns += sched_n_insns; realloc_bb_state_array (saved_last_basic_block); - f = find_fallthru_edge (last_bb->succs); - if (f - && (!f->probability.initialized_p () - || (f->probability.to_reg_br_prob_base () * 100 - / REG_BR_PROB_BASE - >= param_sched_state_edge_prob_cutoff))) - { - memcpy (bb_state[f->dest->index], curr_state, - dfa_state_size); - if (sched_verbose >= 5) - fprintf (sched_dump, "saving state for edge %d->%d\n", - f->src->index, f->dest->index); - } + save_state_for_fallthru_edge (last_bb, curr_state); } else { diff --git a/gcc/symtab-thunks.cc b/gcc/symtab-thunks.cc index b043970..bd50c68 100644 --- a/gcc/symtab-thunks.cc +++ b/gcc/symtab-thunks.cc @@ -635,6 +635,7 @@ expand_thunk (cgraph_node *node, bool output_asm_thunks, } else { + gimple_call_set_ctrl_altering (call, true); gimple_call_set_tail (call, true); cfun->tail_call_marked = true; remove_edge (single_succ_edge (bb)); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e5f2849..21459ed 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,282 @@ +2022-09-11 Tim Lange <mail@tim-lange.me> + + PR analyzer/106845 + * gcc.dg/analyzer/out-of-bounds-zero.c: New test. + * gcc.dg/analyzer/pr106845.c: New test. + +2022-09-10 Takayuki 'January June' Suwa <jjsuwa_sys3175@yahoo.co.jp> + + * gcc.target/xtensa/constsynth_3insns.c (test_4): + Add new test function. + +2022-09-10 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/95644 + * gfortran.dg/ieee/fma_1.f90: New test. + * gfortran.dg/ieee/signbit_1.f90: New test. + +2022-09-09 David Malcolm <dmalcolm@redhat.com> + + * gcc.dg/plugin/analyzer_kernel_plugin.c: New test. + * gcc.dg/plugin/copy_from_user-1.c: New test. + * gcc.dg/plugin/infoleak-1.c: New test. + * gcc.dg/plugin/infoleak-2.c: New test. + * gcc.dg/plugin/infoleak-3.c: New test. + * gcc.dg/plugin/infoleak-CVE-2011-1078-1.c: New test. + * gcc.dg/plugin/infoleak-CVE-2011-1078-2.c: New test. + * gcc.dg/plugin/infoleak-CVE-2014-1446-1.c: New test. + * gcc.dg/plugin/infoleak-CVE-2017-18549-1.c: New test. + * gcc.dg/plugin/infoleak-CVE-2017-18550-1.c: New test. + * gcc.dg/plugin/infoleak-antipatterns-1.c: New test. + * gcc.dg/plugin/infoleak-fixit-1.c: New test. + * gcc.dg/plugin/infoleak-net-ethtool-ioctl.c: New test. + * gcc.dg/plugin/infoleak-vfio_iommu_type1.c: New test. + * gcc.dg/plugin/plugin.exp (plugin_test_list): Add + analyzer_kernel_plugin.c and the new test cases. + * gcc.dg/plugin/taint-CVE-2011-0521-1-fixed.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-1.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-2-fixed.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-2.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-3-fixed.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-3.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-4.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-5-fixed.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-5.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521-6.c: New test. + * gcc.dg/plugin/taint-CVE-2011-0521.h: New test. + * gcc.dg/plugin/taint-antipatterns-1.c: New test. + * gcc.dg/plugin/test-uaccess.h: New header for tests. + +2022-09-09 David Malcolm <dmalcolm@redhat.com> + + * gcc.dg/plugin/analyzer_known_fns_plugin.c: New test plugin. + * gcc.dg/plugin/known-fns-1.c: New test. + * gcc.dg/plugin/plugin.exp (plugin_test_list): Add the new plugin + and test. + +2022-09-09 David Malcolm <dmalcolm@redhat.com> + + PR analyzer/98247 + * gcc.dg/analyzer/flexible-array-member-1.c: New test. + +2022-09-09 Joseph Myers <joseph@codesourcery.com> + + * gcc.dg/c11-unreachable-1.c, gcc.dg/c2x-unreachable-1.c: New + tests. + +2022-09-09 Kewen Lin <linkw@linux.ibm.com> + + PR middle-end/106833 + * gcc.target/powerpc/pr106833.c: New test. + +2022-09-09 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106892 + * gcc.dg/torture/pr106892.c: New testcase. + +2022-09-08 Tobias Burnus <tobias@codesourcery.com> + + PR fortran/106670 + * c-c++-common/gomp/ompx-1.c: New test. + * c-c++-common/gomp/ompx-2.c: New test. + * g++.dg/gomp/ompx-attrs-1.C: New test. + * gfortran.dg/gomp/ompx-1.f90: New test. + * gfortran.dg/gomp/omx-1.f: New test. + * gfortran.dg/gomp/omx-2.f: New test. + +2022-09-08 Jonathan Wakely <jwakely@redhat.com> + + PR c++/106838 + * g++.dg/ext/array4.C: Fix invalid use of __is_constructible. + * g++.dg/ext/unary_trait_incomplete.C: Fix tests for traits with + different requirements. + +2022-09-08 Tim Lange <mail@tim-lange.me> + + PR analyzer/106625 + * gcc.dg/analyzer/data-model-1.c: Change expected result. + * gcc.dg/analyzer/out-of-bounds-5.c: New test. + * gcc.dg/analyzer/out-of-bounds-realloc-grow.c: New test. + * gcc.dg/analyzer/symbolic-gt-1.c: New test. + +2022-09-08 Richard Sandiford <richard.sandiford@arm.com> + + PR tree-optimization/106886 + * gcc.dg/vect/bb-slp-layout-21.c: New test. + +2022-09-08 Patrick Palka <ppalka@redhat.com> + + PR c++/99209 + * g++.dg/cpp2a/lambda-uneval17.C: New test. + +2022-09-08 Patrick Palka <ppalka@redhat.com> + + PR c++/99130 + * g++.dg/cpp0x/constexpr-decltype5.C: New test. + +2022-09-08 Jakub Jelinek <jakub@redhat.com> + + * c-c++-common/gomp/doacross-7.c: New test. + +2022-09-08 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106881 + * gcc.dg/uninit-pr106881.c: New testcase. + +2022-09-08 Richard Biener <rguenther@suse.de> + + PR testsuite/106872 + * gcc.dg/uninit-pred-12.c: Adjust. + +2022-09-07 Jason Merrill <jason@redhat.com> + + PR c++/106793 + * g++.dg/cpp23/auto-array2.C: Adjust. + * g++.dg/cpp1z/class-deduction113.C: New test. + +2022-09-07 Surya Kumari Jangala <jskumari@linux.ibm.com> + + PR rtl-optimization/105586 + * gcc.target/powerpc/pr105586.c: New test. + +2022-09-07 Arsen Arsenović <arsen@aarsen.me> + + PR c++/106188 + PR c++/106713 + * g++.dg/coroutines/pr106188.C: New test. + +2022-09-07 Joseph Myers <joseph@codesourcery.com> + + * gcc.dg/c11-keywords-1.c, gcc.dg/c2x-align-1.c, + gcc.dg/c2x-align-6.c, gcc.dg/c2x-bool-2.c, + gcc.dg/c2x-static-assert-3.c, gcc.dg/c2x-static-assert-4.c, + gcc.dg/c2x-thread-local-1.c: New tests. + * gcc.dg/c2x-bool-1.c: Update expectations. + +2022-09-07 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106866 + * gcc.dg/uninit-pr106866.c: New testcase. + +2022-09-07 Aldy Hernandez <aldyh@redhat.com> + + PR tree-optimization/106867 + * gcc.dg/tree-ssa/pr106867.c: New test. + +2022-09-07 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106860 + * g++.dg/opt/pr106860.C: New testcase. + +2022-09-07 Richard Sandiford <richard.sandiford@arm.com> + + * gcc.target/aarch64/movqi_1.c: New test. + * gcc.target/aarch64/movhi_1.c: Likewise. + * gcc.target/aarch64/movsi_1.c: Likewise. + * gcc.target/aarch64/movdi_2.c: Likewise. + * gcc.target/aarch64/movti_2.c: Likewise. + * gcc.target/aarch64/movhf_1.c: Likewise. + * gcc.target/aarch64/movsf_1.c: Likewise. + * gcc.target/aarch64/movdf_1.c: Likewise. + * gcc.target/aarch64/movtf_2.c: Likewise. + * gcc.target/aarch64/movv8qi_1.c: Likewise. + * gcc.target/aarch64/movv16qi_1.c: Likewise. + +2022-09-07 Richard Sandiford <richard.sandiford@arm.com> + + * gcc.target/aarch64/nofp_2.c: New test. + +2022-09-07 Lulu Cheng <chenglulu@loongson.cn> + + PR target/106828 + * g++.target/loongarch/pr106828.C: New test. + +2022-09-07 Jakub Jelinek <jakub@redhat.com> + + PR c++/106829 + * g++.dg/gomp/pr106829.C: New test. + +2022-09-07 Jakub Jelinek <jakub@redhat.com> + + * c-c++-common/cpp/delimited-escape-seq-4.c: New test. + * c-c++-common/cpp/delimited-escape-seq-5.c: New test. + * c-c++-common/cpp/delimited-escape-seq-6.c: New test. + * c-c++-common/cpp/delimited-escape-seq-7.c: New test. + * c-c++-common/cpp/named-universal-char-escape-5.c: New test. + * c-c++-common/cpp/named-universal-char-escape-6.c: New test. + * c-c++-common/cpp/named-universal-char-escape-7.c: New test. + * g++.dg/cpp23/named-universal-char-escape1.C: New test. + * g++.dg/cpp23/named-universal-char-escape2.C: New test. + +2022-09-07 Kewen Lin <linkw@linux.ibm.com> + + PR testsuite/106345 + * lib/target-supports.exp (check_effective_target_powerpc_sqrt): Add + a function definition to avoid pedwarn about empty translation unit. + (check_effective_target_has_arch_pwr5): Likewise. + (check_effective_target_has_arch_pwr6): Likewise. + (check_effective_target_has_arch_pwr7): Likewise. + (check_effective_target_has_arch_pwr8): Likewise. + (check_effective_target_has_arch_pwr9): Likewise. + (check_effective_target_has_arch_pwr10): Likewise. + (check_effective_target_has_arch_ppc64): Likewise. + (check_effective_target_ppc_float128): Likewise. + (check_effective_target_ppc_float128_insns): Likewise. + (check_effective_target_powerpc_vsx): Likewise. + +2022-09-07 liuhongt <hongtao.liu@intel.com> + + * gcc.target/i386/pr103144-mul-1.c: New test. + * gcc.target/i386/pr103144-mul-2.c: New test. + * gcc.target/i386/pr103144-neg-1.c: New test. + * gcc.target/i386/pr103144-neg-2.c: New test. + * gcc.target/i386/pr103144-shift-1.c: New test. + * gcc.target/i386/pr103144-shift-2.c: New test. + +2022-09-06 Jason Merrill <jason@redhat.com> + + * g++.dg/cpp23/subscript8.C: New test. + +2022-09-06 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106754 + * gcc.dg/uninit-pred-12.c: New testcase. + * gcc.dg/uninit-pr106155-1.c: Likewise. + +2022-09-06 Aldy Hernandez <aldyh@redhat.com> + + * gcc.dg/tree-ssa/vrp-float-inf-1.c: New test. + +2022-09-06 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106844 + * gcc.dg/pr106844.c: New testcase. + +2022-09-06 Richard Biener <rguenther@suse.de> + + PR tree-optimization/106841 + * g++.dg/vect/pr106841.cc: New testcase. + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + * c-c++-common/gomp/doacross-6.c (corge): Don't expect an error here. + Add a few further tests. + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + PR c/106836 + * c-c++-common/gomp/pr106836.c: New test. + +2022-09-06 Jakub Jelinek <jakub@redhat.com> + + * c-c++-common/gomp/sink-3.c: Don't expect a superfluous error during + error recovery. + * c-c++-common/gomp/doacross-6.c (foo): Add further tests. + +2022-09-06 liuhongt <hongtao.liu@intel.com> + + * gcc.target/i386/avx512f-vcvtps2ph-sae.c: New test. + 2022-09-05 Joseph Myers <joseph@codesourcery.com> * gcc.dg/cpp/c11-trigraphs-1.c, gcc.dg/cpp/c2x-trigraphs-1.c, diff --git a/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-4.c b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-4.c new file mode 100644 index 0000000..107051f --- /dev/null +++ b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-4.c @@ -0,0 +1,13 @@ +/* P2290R3 - Delimited escape sequences */ +/* { dg-do compile } */ +/* { dg-require-effective-target wchar } */ +/* { dg-options "-std=gnu99 -Wno-c++-compat" { target c } } */ +/* { dg-options "-std=gnu++20" { target c++ } } */ + +#define z(x) 0 +#define a z( +int b = a\u{}); /* { dg-warning "empty delimited escape sequence; treating it as separate tokens" } */ +int c = a\u{); /* { dg-warning "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{; treating it as separate tokens" } */ +int d = a\u{12XYZ}); /* { dg-warning "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{12; treating it as separate tokens" } */ +int e = a\u123); +int f = a\U1234567); diff --git a/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-5.c b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-5.c new file mode 100644 index 0000000..e04f519 --- /dev/null +++ b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-5.c @@ -0,0 +1,13 @@ +/* P2290R3 - Delimited escape sequences */ +/* { dg-do compile } */ +/* { dg-require-effective-target wchar } */ +/* { dg-options "-std=c17 -Wno-c++-compat" { target c } } */ +/* { dg-options "-std=c++23" { target c++ } } */ + +#define z(x) 0 +#define a z( +int b = a\u{}); /* { dg-warning "empty delimited escape sequence; treating it as separate tokens" "" { target c++23 } } */ +int c = a\u{); /* { dg-warning "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{; treating it as separate tokens" "" { target c++23 } } */ +int d = a\u{12XYZ}); /* { dg-warning "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{12; treating it as separate tokens" "" { target c++23 } } */ +int e = a\u123); +int f = a\U1234567); diff --git a/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-6.c b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-6.c new file mode 100644 index 0000000..f2a4e93 --- /dev/null +++ b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-6.c @@ -0,0 +1,13 @@ +/* P2290R3 - Delimited escape sequences */ +/* { dg-do compile } */ +/* { dg-require-effective-target wchar } */ +/* { dg-options "-std=gnu99 -Wno-c++-compat -Wno-unicode" { target c } } */ +/* { dg-options "-std=gnu++20 -Wno-unicode" { target c++ } } */ + +#define z(x) 0 +#define a z( +int b = a\u{}); /* { dg-bogus "empty delimited escape sequence; treating it as separate tokens" } */ +int c = a\u{); /* { dg-bogus "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{; treating it as separate tokens" } */ +int d = a\u{12XYZ}); /* { dg-bogus "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{12; treating it as separate tokens" } */ +int e = a\u123); +int f = a\U1234567); diff --git a/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-7.c b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-7.c new file mode 100644 index 0000000..e2f0da4 --- /dev/null +++ b/gcc/testsuite/c-c++-common/cpp/delimited-escape-seq-7.c @@ -0,0 +1,13 @@ +/* P2290R3 - Delimited escape sequences */ +/* { dg-do compile } */ +/* { dg-require-effective-target wchar } */ +/* { dg-options "-std=c17 -Wno-c++-compat -Wno-unicode" { target c } } */ +/* { dg-options "-std=c++23 -Wno-unicode" { target c++ } } */ + +#define z(x) 0 +#define a z( +int b = a\u{}); /* { dg-bogus "empty delimited escape sequence; treating it as separate tokens" } */ +int c = a\u{); /* { dg-bogus "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{; treating it as separate tokens" } */ +int d = a\u{12XYZ}); /* { dg-bogus "'\\\\u\\\{' not terminated with '\\\}' after \\\\u\\\{12; treating it as separate tokens" } */ +int e = a\u123); +int f = a\U1234567); diff --git a/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-5.c b/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-5.c new file mode 100644 index 0000000..a1c53c7 --- /dev/null +++ b/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-5.c @@ -0,0 +1,17 @@ +/* P2071R2 - Named universal character escapes */ +/* { dg-do compile } */ +/* { dg-require-effective-target wchar } */ +/* { dg-options "-std=gnu99 -Wno-c++-compat" { target c } } */ +/* { dg-options "-std=gnu++20" { target c++ } } */ + +#define z(x) 0 +#define a z( +int b = a\N{}); /* { dg-warning "empty named universal character escape sequence; treating it as separate tokens" } */ +int c = a\N{); /* { dg-warning "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{; treating it as separate tokens" } */ +int d = a\N); +int e = a\NARG); +int f = a\N{abc}); /* { dg-warning "\\\\N\\\{abc\\\} is not a valid universal character; treating it as separate tokens" } */ +int g = a\N{ABC.123}); /* { dg-warning "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{ABC; treating it as separate tokens" } */ +int h = a\N{NON-EXISTENT CHAR}); /* { dg-warning "\\\\N\\\{NON-EXISTENT CHAR\\\} is not a valid universal character; treating it as separate tokens" } */ +int i = a\N{Latin_Small_Letter_A_With_Acute}); /* { dg-warning "\\\\N\\\{Latin_Small_Letter_A_With_Acute\\\} is not a valid universal character; treating it as separate tokens" } */ + /* { dg-message "did you mean \\\\N\\\{LATIN SMALL LETTER A WITH ACUTE\\\}\\?" "" { target *-*-* } .-1 } */ diff --git a/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-6.c b/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-6.c new file mode 100644 index 0000000..a6a5a10 --- /dev/null +++ b/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-6.c @@ -0,0 +1,17 @@ +/* P2071R2 - Named universal character escapes */ +/* { dg-do compile } */ +/* { dg-require-effective-target wchar } */ +/* { dg-options "-std=c17 -Wno-c++-compat" { target c } } */ +/* { dg-options "-std=c++20" { target c++ } } */ + +#define z(x) 0 +#define a z( +int b = a\N{}); +int c = a\N{); +int d = a\N); +int e = a\NARG); +int f = a\N{abc}); +int g = a\N{ABC.123}); +int h = a\N{NON-EXISTENT CHAR}); /* { dg-bogus "is not a valid universal character" } */ +int i = a\N{Latin_Small_Letter_A_With_Acute}); +int j = a\N{LATIN SMALL LETTER A WITH ACUTE}); diff --git a/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-7.c b/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-7.c new file mode 100644 index 0000000..e6142bf --- /dev/null +++ b/gcc/testsuite/c-c++-common/cpp/named-universal-char-escape-7.c @@ -0,0 +1,17 @@ +/* P2071R2 - Named universal character escapes */ +/* { dg-do compile } */ +/* { dg-require-effective-target wchar } */ +/* { dg-options "-std=gnu99 -Wno-c++-compat -Wno-unicode" { target c } } */ +/* { dg-options "-std=gnu++20 -Wno-unicode" { target c++ } } */ + +#define z(x) 0 +#define a z( +int b = a\N{}); /* { dg-bogus "empty named universal character escape sequence; treating it as separate tokens" } */ +int c = a\N{); /* { dg-bogus "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{; treating it as separate tokens" } */ +int d = a\N); +int e = a\NARG); +int f = a\N{abc}); /* { dg-bogus "\\\\N\\\{abc\\\} is not a valid universal character; treating it as separate tokens" } */ +int g = a\N{ABC.123}); /* { dg-bogus "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{ABC; treating it as separate tokens" } */ +int h = a\N{NON-EXISTENT CHAR}); /* { dg-bogus "\\\\N\\\{NON-EXISTENT CHAR\\\} is not a valid universal character; treating it as separate tokens" } */ +int i = a\N{Latin_Small_Letter_A_With_Acute}); /* { dg-bogus "\\\\N\\\{Latin_Small_Letter_A_With_Acute\\\} is not a valid universal character; treating it as separate tokens" } */ + /* { dg-bogus "did you mean \\\\N\\\{LATIN SMALL LETTER A WITH ACUTE\\\}\\?" "" { target *-*-* } .-1 } */ diff --git a/gcc/testsuite/c-c++-common/gomp/doacross-6.c b/gcc/testsuite/c-c++-common/gomp/doacross-6.c index d126ad1..65ee897 100644 --- a/gcc/testsuite/c-c++-common/gomp/doacross-6.c +++ b/gcc/testsuite/c-c++-common/gomp/doacross-6.c @@ -22,6 +22,18 @@ foo (int n) { #pragma omp ordered doacross(sink) /* { dg-error "expected ':' before '\\\)' token" } */ } + #pragma omp for ordered + for (i = 0; i < 8; i += n) + { + #pragma omp ordered doacross(source) /* { dg-error "expected ':' before '\\\)' token" } */ + #pragma omp ordered doacross(sink:i-1) + } + #pragma omp for ordered + for (i = 0; i < 8; i += n) + { + #pragma omp ordered doacross(source:) + #pragma omp ordered doacross(sink) /* { dg-error "expected ':' before '\\\)' token" } */ + } } void @@ -69,6 +81,26 @@ corge (int n) #pragma omp for ordered for (i = 0; i < 8; i += n) { - #pragma omp ordered doacross(sink:omp_cur_iteration - 1LL) /* { dg-error "'omp_cur_iteration' undeclared \\\(first use in this function\\\)" "" { target c } } */ - } /* { dg-error "'omp_cur_iteration' has not been declared" "" { target c++ } .-1 } */ + #pragma omp ordered doacross(sink:omp_cur_iteration - 1) + } + #pragma omp for ordered + for (i = 0; i < 8; i += n) + { + #pragma omp ordered doacross(sink:omp_cur_iteration - 1LL) + } + #pragma omp for ordered + for (i = 0; i < 8; i += n) + { + #pragma omp ordered doacross(sink:omp_cur_iteration - 0x00001) + } + #pragma omp for ordered + for (i = 0; i < 8; i += n) + { + #pragma omp ordered doacross(sink:omp_cur_iteration - 001) + } + #pragma omp for ordered + for (i = 0; i < 8; i += n) + { + #pragma omp ordered doacross(sink:omp_cur_iteration - 1ULL) + } } diff --git a/gcc/testsuite/c-c++-common/gomp/doacross-7.c b/gcc/testsuite/c-c++-common/gomp/doacross-7.c new file mode 100644 index 0000000..8ead167 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/doacross-7.c @@ -0,0 +1,78 @@ +void +foo (int l) +{ + int i, j, k; + #pragma omp parallel + { + #pragma omp for schedule(static) ordered (3) + for (i = 2; i < 256 / 16 - 1; i++) + for (j = 0; j < 8; j += 2) + for (k = 1; k <= 3; k++) + { + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source:) + } + #pragma omp for schedule(static) ordered (3) collapse(2) + for (i = 2; i < 256 / 16 - 1; i++) + for (j = 0; j < 8; j += 2) + for (k = 1; k <= 3; k++) + { + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source:) + } + #pragma omp for schedule(static) ordered (3) collapse(3) + for (i = 2; i < 256 / 16 - 1; i++) + for (j = 0; j < 8; j += 2) + for (k = 1; k <= 3; k++) + { + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source: omp_cur_iteration) + } + #pragma omp for schedule(static) ordered (1) nowait + for (i = 2; i < 256 / 16 - 1; i += l) + { + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source:) + } + } +} + +void +bar (int l, int m, int n, int o) +{ + int i, j, k; + #pragma omp for schedule(static) ordered (3) + for (i = 2; i < 256 / 16 - 1; i++) + for (j = 0; j < m; j += n) + for (k = o; k <= 3; k++) + { + foo (l); + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source:omp_cur_iteration) + } + #pragma omp for schedule(static) ordered (3) collapse(2) + for (i = 2; i < 256 / 16 - m; i += n) + for (j = 0; j < 8; j += o) + for (k = 1; k <= 3; k++) + { + foo (l); + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source : omp_cur_iteration) + } + #pragma omp for schedule(static) ordered (3) collapse(3) + for (i = m; i < 256 / 16 - 1; i++) + for (j = 0; j < n; j += 2) + for (k = 1; k <= o; k++) + { + foo (l); + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source :) + } + #pragma omp for schedule(static) ordered + for (i = m; i < n / 16 - 1; i += l) + { + foo (l); + #pragma omp ordered doacross(sink: omp_cur_iteration - 1) + #pragma omp ordered doacross(source: omp_cur_iteration) + } +} diff --git a/gcc/testsuite/c-c++-common/gomp/ompx-1.c b/gcc/testsuite/c-c++-common/gomp/ompx-1.c new file mode 100644 index 0000000..9758d0f --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/ompx-1.c @@ -0,0 +1,4 @@ +void f(void) +{ + #pragma ompx some_vendor_extension +} diff --git a/gcc/testsuite/c-c++-common/gomp/ompx-2.c b/gcc/testsuite/c-c++-common/gomp/ompx-2.c new file mode 100644 index 0000000..4b66b0e --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/ompx-2.c @@ -0,0 +1,5 @@ +/* { dg-additional-options "-Wunknown-pragmas" } */ +void f(void) +{ + #pragma ompx some_vendor_extension /* { dg-warning "-:ignoring '#pragma ompx some_vendor_extension'" } */ +} diff --git a/gcc/testsuite/c-c++-common/gomp/pr106836.c b/gcc/testsuite/c-c++-common/gomp/pr106836.c new file mode 100644 index 0000000..6df8250 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/pr106836.c @@ -0,0 +1,9 @@ +/* PR c/106836 */ + +void +foo (void) +{ +#pragma omp target parallel depend (source) /* { dg-error "'depend\\\(source\\\)' is only allowed in 'omp ordered'" } */ + ; +#pragma omp taskwait +} diff --git a/gcc/testsuite/c-c++-common/gomp/sink-3.c b/gcc/testsuite/c-c++-common/gomp/sink-3.c index 3f7ba5e..7cb16ed 100644 --- a/gcc/testsuite/c-c++-common/gomp/sink-3.c +++ b/gcc/testsuite/c-c++-common/gomp/sink-3.c @@ -14,7 +14,7 @@ foo () for (i=0; i < 100; ++i) { #pragma omp ordered depend(sink:poo-1,paa+1) /* { dg-error "poo.*declared.*paa.*declared" } */ - bar(&i); /* { dg-error "must not have the same binding region" "" { target *-*-* } .-1 } */ + bar(&i); #pragma omp ordered depend(source) } } diff --git a/gcc/testsuite/g++.dg/coroutines/pr106188.C b/gcc/testsuite/g++.dg/coroutines/pr106188.C new file mode 100644 index 0000000..9db3778 --- /dev/null +++ b/gcc/testsuite/g++.dg/coroutines/pr106188.C @@ -0,0 +1,34 @@ +// { dg-do run { target c++20 } } +// test case from pr106188, w/o workaround +#include <coroutine> + +struct task { + struct promise_type { + task get_return_object() { return task{}; } + void return_void() {} + void unhandled_exception() {} + auto initial_suspend() noexcept { return std::suspend_never{}; } + auto final_suspend() noexcept { return std::suspend_never{}; } + }; +}; + +struct suspend_and_resume { + bool await_ready() const { return false; } + void await_suspend(std::coroutine_handle<> h) { h.resume(); } + void await_resume() {} +}; + +task f() { + if (co_await suspend_and_resume{}, false) {} +} + +task g() { + switch (co_await suspend_and_resume{}, 0) { + default: break; + } +} + +int main() { + f(); + g(); +} diff --git a/gcc/testsuite/g++.dg/cpp0x/constexpr-decltype5.C b/gcc/testsuite/g++.dg/cpp0x/constexpr-decltype5.C new file mode 100644 index 0000000..5411226 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/constexpr-decltype5.C @@ -0,0 +1,23 @@ +// PR c++/99130 +// { dg-do compile { target c++11 } } + +template<class T> +struct A { + static constexpr int value = T::nonexistent; +}; + +using type = const int; +using type = decltype(A<int>::value); + +#if __cpp_variable_templates +struct B { + template<class T> + static constexpr int value = T::nonexistent; +}; + +template<class T> +constexpr int value = T::nonexistent; + +using type = decltype(B::value<int>); +using type = decltype(value<int>); +#endif diff --git a/gcc/testsuite/g++.dg/cpp1z/class-deduction113.C b/gcc/testsuite/g++.dg/cpp1z/class-deduction113.C new file mode 100644 index 0000000..8f6908e --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp1z/class-deduction113.C @@ -0,0 +1,5 @@ +// PR c++/106793 + +template <class T> struct A { A(T); }; +template <class T> void f(A *a); // { dg-error "placeholder.*parameter" "" { target c++17 } } +// { dg-error "" "" { target c++14_down } .-1 } diff --git a/gcc/testsuite/g++.dg/cpp23/auto-array2.C b/gcc/testsuite/g++.dg/cpp23/auto-array2.C index 0643168..3fc2eae 100644 --- a/gcc/testsuite/g++.dg/cpp23/auto-array2.C +++ b/gcc/testsuite/g++.dg/cpp23/auto-array2.C @@ -5,7 +5,7 @@ template<class T> struct A { A(); }; A<int> a[3]; auto (*p)[3] = &a; A<int> (*p2)[3] = &a; -A (*p3)[3] = &a; // { dg-error "template placeholder type" } +A (*p3)[3] = &a; // { dg-error "template placeholder" } auto (&r)[3] = a; A<int> (&r2)[3] = a; -A (&r3)[3] = a; // { dg-error "template placeholder type" } +A (&r3)[3] = a; // { dg-error "template placeholder" } diff --git a/gcc/testsuite/g++.dg/cpp23/named-universal-char-escape1.C b/gcc/testsuite/g++.dg/cpp23/named-universal-char-escape1.C new file mode 100644 index 0000000..fe49482 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp23/named-universal-char-escape1.C @@ -0,0 +1,16 @@ +// P2071R2 - Named universal character escapes +// { dg-do compile } +// { dg-require-effective-target wchar } + +#define z(x) 0 +#define a z( +int b = a\N{}); // { dg-warning "empty named universal character escape sequence; treating it as separate tokens" "" { target c++23 } } +int c = a\N{); // { dg-warning "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{; treating it as separate tokens" "" { target c++23 } } +int d = a\N); +int e = a\NARG); +int f = a\N{abc}); // { dg-warning "\\\\N\\\{abc\\\} is not a valid universal character; treating it as separate tokens" "" { target c++23 } } +int g = a\N{ABC.123}); // { dg-warning "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{ABC; treating it as separate tokens" "" { target c++23 } } +int h = a\N{NON-EXISTENT CHAR}); // { dg-error "is not a valid universal character" "" { target c++23 } } + // { dg-error "was not declared in this scope" "" { target c++23 } .-1 } +int i = a\N{Latin_Small_Letter_A_With_Acute}); // { dg-warning "\\\\N\\\{Latin_Small_Letter_A_With_Acute\\\} is not a valid universal character; treating it as separate tokens" "" { target c++23 } } + // { dg-message "did you mean \\\\N\\\{LATIN SMALL LETTER A WITH ACUTE\\\}\\?" "" { target c++23 } .-1 } diff --git a/gcc/testsuite/g++.dg/cpp23/named-universal-char-escape2.C b/gcc/testsuite/g++.dg/cpp23/named-universal-char-escape2.C new file mode 100644 index 0000000..8699e09 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp23/named-universal-char-escape2.C @@ -0,0 +1,18 @@ +// P2071R2 - Named universal character escapes +// { dg-do compile } +// { dg-require-effective-target wchar } +// { dg-options "" } + +#define z(x) 0 +#define a z( +int b = a\N{}); // { dg-warning "empty named universal character escape sequence; treating it as separate tokens" } +int c = a\N{); // { dg-warning "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{; treating it as separate tokens" } +int d = a\N); +int e = a\NARG); +int f = a\N{abc}); // { dg-warning "\\\\N\\\{abc\\\} is not a valid universal character; treating it as separate tokens" } +int g = a\N{ABC.123}); // { dg-warning "'\\\\N\\\{' not terminated with '\\\}' after \\\\N\\\{ABC; treating it as separate tokens" } +int h = a\N{NON-EXISTENT CHAR}); // { dg-error "is not a valid universal character" "" { target c++23 } } + // { dg-error "was not declared in this scope" "" { target c++23 } .-1 } + // { dg-warning "\\\\N\\\{NON-EXISTENT CHAR\\\} is not a valid universal character; treating it as separate tokens" "" { target c++20_down } .-2 } +int i = a\N{Latin_Small_Letter_A_With_Acute}); // { dg-warning "\\\\N\\\{Latin_Small_Letter_A_With_Acute\\\} is not a valid universal character; treating it as separate tokens" } + // { dg-message "did you mean \\\\N\\\{LATIN SMALL LETTER A WITH ACUTE\\\}\\?" "" { target *-*-* } .-1 } diff --git a/gcc/testsuite/g++.dg/cpp23/subscript8.C b/gcc/testsuite/g++.dg/cpp23/subscript8.C new file mode 100644 index 0000000..fe00035 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp23/subscript8.C @@ -0,0 +1,7 @@ +// DR2507: Allow default arguments +// { dg-additional-options {-std=c++23} } + +struct A +{ + void operator[](int, int = 42); +}; diff --git a/gcc/testsuite/g++.dg/cpp2a/lambda-uneval17.C b/gcc/testsuite/g++.dg/cpp2a/lambda-uneval17.C new file mode 100644 index 0000000..74e0f87 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/lambda-uneval17.C @@ -0,0 +1,17 @@ +// PR c++/99209 +// { dg-do compile { target c++20 } } + +constexpr char f(...) = delete; +constexpr decltype(auto) f_adl(auto a) { return f(a); } + +namespace A { + constexpr char f(auto) { return 'A'; } + template<char TemplateParam = f_adl([]{})> void g(char FunctionParam = f_adl([]{})) { + char Local = f_adl([]{}); + } +} + +namespace B { + constexpr char f(auto) = delete; + void call() { A::g(); } +} diff --git a/gcc/testsuite/g++.dg/ext/array4.C b/gcc/testsuite/g++.dg/ext/array4.C index 0068ea8..6adf9a3 100644 --- a/gcc/testsuite/g++.dg/ext/array4.C +++ b/gcc/testsuite/g++.dg/ext/array4.C @@ -16,7 +16,6 @@ template <typename _Tp> constexpr integral_constant<true> __is_complete_or_unbounded(_Tp) { return {}; } -struct Trans_NS_std_formatter; template <typename _Tp> struct is_default_constructible : integral_constant<false> { static_assert(__is_complete_or_unbounded(_Tp{}), ""); @@ -53,7 +52,7 @@ template <typename> struct basic_string_view { basic_string_view(int, int); }; template <typename, typename> struct formatter; template <typename, typename> using has_formatter = - __bool_constant<__is_constructible(Trans_NS_std_formatter)>; + __bool_constant<__is_constructible(void)>; struct fallback_formatter; template <typename Context> struct custom_value { using parse_context = typename Context::parse_context_type; diff --git a/gcc/testsuite/g++.dg/ext/unary_trait_incomplete.C b/gcc/testsuite/g++.dg/ext/unary_trait_incomplete.C index 6c83279..1dfa449 100644 --- a/gcc/testsuite/g++.dg/ext/unary_trait_incomplete.C +++ b/gcc/testsuite/g++.dg/ext/unary_trait_incomplete.C @@ -2,6 +2,7 @@ struct I; // { dg-message "forward declaration" } struct C { }; +union U; // { dg-message "forward declaration" } bool nas1 = __has_nothrow_assign(I); // { dg-error "incomplete type" } bool nas2 = __has_nothrow_assign(C[]); @@ -39,38 +40,105 @@ bool tcp3 = __has_trivial_copy(I[]); bool tcp4 = __has_trivial_copy(void); bool tcp5 = __has_trivial_copy(const void); -bool vde1 = __has_virtual_destructor(I); // { dg-error "incomplete type" } -bool vde2 = __has_virtual_destructor(C[]); -bool vde3 = __has_virtual_destructor(I[]); -bool vde4 = __has_virtual_destructor(void); -bool vde5 = __has_virtual_destructor(const void); - bool tde1 = __has_trivial_destructor(I); // { dg-error "incomplete type" } bool tde2 = __has_trivial_destructor(C[]); bool tde3 = __has_trivial_destructor(I[]); bool tde4 = __has_trivial_destructor(void); bool tde5 = __has_trivial_destructor(const void); -bool abs1 = __is_abstract(I); // { dg-error "incomplete type" } -bool abs2 = __is_abstract(C[]); -bool abs3 = __is_abstract(I[]); -bool abs4 = __is_abstract(void); -bool abs5 = __is_abstract(const void); +// T shall be a complete type, cv void, or an array of unknown bound. -bool pod1 = __is_pod(I); // { dg-error "incomplete type" } -bool pod2 = __is_pod(C[]); -bool pod3 = __is_pod(I[]); -bool pod4 = __is_pod(void); -bool pod5 = __is_pod(const void); +bool con1 = __is_constructible(C); +bool con2 = __is_constructible(I); // { dg-error "incomplete type" } +bool con3 = __is_constructible(U); // { dg-error "incomplete type" } +bool con4 = __is_constructible(C[]); +bool con5 = __is_constructible(I[]); +bool con6 = __is_constructible(U[]); +bool con7 = __is_constructible(C[1]); +bool con8 = __is_constructible(I[1]); // { dg-error "incomplete type" } +bool con9 = __is_constructible(U[1]); // { dg-error "incomplete type" } +bool con10 = __is_constructible(void); +bool con11 = __is_constructible(const void); + +// If T is a non-union class type, T shall be a complete type. + +bool vde1 = __has_virtual_destructor(I); // { dg-error "incomplete type" } +bool vde2 = __has_virtual_destructor(U); +bool vde3 = __has_virtual_destructor(C[]); +bool vde4 = __has_virtual_destructor(I[]); +bool vde5 = __has_virtual_destructor(U[]); +bool vde6 = __has_virtual_destructor(C[1]); +bool vde7 = __has_virtual_destructor(I[1]); +bool vde8 = __has_virtual_destructor(U[1]); +bool vde9 = __has_virtual_destructor(void); +bool vde10 = __has_virtual_destructor(const void); + +bool abs1 = __is_abstract(I); // { dg-error "incomplete type" } +bool abs2 = __is_abstract(U); +bool abs3 = __is_abstract(C[]); +bool abs4 = __is_abstract(I[]); +bool abs5 = __is_abstract(U[]); +bool abs6 = __is_abstract(C[1]); +bool abs7 = __is_abstract(I[1]); +bool abs8 = __is_abstract(U[1]); +bool abs9 = __is_abstract(void); +bool abs10 = __is_abstract(const void); bool emp1 = __is_empty(I); // { dg-error "incomplete type" } -bool emp2 = __is_empty(C[]); -bool emp3 = __is_empty(I[]); -bool emp4 = __is_empty(void); -bool emp5 = __is_empty(const void); +bool emp2 = __is_empty(U); +bool emp3 = __is_empty(C[]); +bool emp4 = __is_empty(I[]); +bool emp5 = __is_empty(U[]); +bool emp6 = __is_empty(C[1]); +bool emp7 = __is_empty(I[1]); +bool emp8 = __is_empty(U[1]); +bool emp9 = __is_empty(void); +bool emp10 = __is_empty(const void); bool pol1 = __is_polymorphic(I); // { dg-error "incomplete type" } -bool pol2 = __is_polymorphic(C[]); -bool pol3 = __is_polymorphic(I[]); -bool pol4 = __is_polymorphic(void); -bool pol5 = __is_polymorphic(const void); +bool pol2 = __is_polymorphic(U); +bool pol3 = __is_polymorphic(C[]); +bool pol4 = __is_polymorphic(I[]); +bool pol5 = __is_polymorphic(U[]); +bool pol6 = __is_polymorphic(C[1]); +bool pol7 = __is_polymorphic(I[1]); +bool pol8 = __is_polymorphic(U[1]); +bool pol9 = __is_polymorphic(void); +bool pol10 = __is_polymorphic(const void); + +// If T is a class type, T shall be a complete type. + +bool agg1 = __is_aggregate(I); // { dg-error "incomplete type" } +bool agg2 = __is_aggregate(U); // { dg-error "incomplete type" } +bool agg3 = __is_aggregate(C[]); +bool agg4 = __is_aggregate(I[]); +bool agg5 = __is_aggregate(U[]); +bool agg6 = __is_aggregate(C[1]); +bool agg7 = __is_aggregate(I[1]); +bool agg8 = __is_aggregate(U[1]); +bool agg9 = __is_aggregate(void); +bool agg10 = __is_aggregate(const void); + +bool fin1 = __is_final(I); // { dg-error "incomplete type" } +bool fin2 = __is_final(U); // { dg-error "incomplete type" } +bool fin3 = __is_final(C[]); +bool fin4 = __is_final(I[]); +bool fin5 = __is_final(U[]); +bool fin6 = __is_final(C[1]); +bool fin7 = __is_final(I[1]); +bool fin8 = __is_final(U[1]); +bool fin9 = __is_final(void); +bool fin10 = __is_final(const void); + +// remove_all_extents_t<T> shall be a complete type or cv void. + +bool pod1 = __is_pod(I); // { dg-error "incomplete type" } +bool pod2 = __is_pod(U); // { dg-error "incomplete type" } +bool pod3 = __is_pod(C[]); +bool pod4 = __is_pod(I[]); // { dg-error "incomplete type" } +bool pod5 = __is_pod(U[]); // { dg-error "incomplete type" } +bool pod6 = __is_pod(C[1]); +bool pod7 = __is_pod(I[1]); // { dg-error "incomplete type" } +bool pod8 = __is_pod(U[1]); // { dg-error "incomplete type" } +bool pod9 = __is_pod(void); +bool pod10 = __is_pod(const void); diff --git a/gcc/testsuite/g++.dg/gomp/ompx-attrs-1.C b/gcc/testsuite/g++.dg/gomp/ompx-attrs-1.C new file mode 100644 index 0000000..2e9fc0b --- /dev/null +++ b/gcc/testsuite/g++.dg/gomp/ompx-attrs-1.C @@ -0,0 +1,7 @@ +// { dg-do compile { target c++11 } } + +void +foo () +{ + [[ompx::directive(some_vendor_extension)]]; /* { dg-warning "attributes at the beginning of statement are ignored" } */ +} diff --git a/gcc/testsuite/g++.dg/gomp/pr106829.C b/gcc/testsuite/g++.dg/gomp/pr106829.C new file mode 100644 index 0000000..0295efb --- /dev/null +++ b/gcc/testsuite/g++.dg/gomp/pr106829.C @@ -0,0 +1,15 @@ +// PR c++/106829 + +namespace std +{ + template <typename> class complex; + template <> struct complex<double> { complex (double); _Complex double d; }; +} +struct S { void static foo (); }; + +void +S::foo () +{ +#pragma omp target + std::complex<double> c = 0.0; +} diff --git a/gcc/testsuite/g++.dg/opt/pr106860.C b/gcc/testsuite/g++.dg/opt/pr106860.C new file mode 100644 index 0000000..a0209dc --- /dev/null +++ b/gcc/testsuite/g++.dg/opt/pr106860.C @@ -0,0 +1,23 @@ +// { dg-do compile } +// { dg-options "-Ofast -ftrapv -fnon-call-exceptions -fno-tree-fre" } + +static const int N = 12; +int nSlip; + +int main () +{ + int i, j, k, fdot = 0; + int a[N][N]; + + for ( i = 1; i < nSlip; i++) + { + for ( j = i+1; j < nSlip; j++) + { + for ( k = 0; k < i; k++) + fdot += a[i][k] * a[k][j]; + a[i][j] = a[i][j] - fdot; + } + } + + return 0; +} diff --git a/gcc/testsuite/g++.dg/vect/pr106841.cc b/gcc/testsuite/g++.dg/vect/pr106841.cc new file mode 100644 index 0000000..7458bc1 --- /dev/null +++ b/gcc/testsuite/g++.dg/vect/pr106841.cc @@ -0,0 +1,52 @@ +// { dg-do compile } +// { dg-additional-options "-O3 -ffast-math" } +// { dg-additional-options "-march=bdver2" { target x86_64-*-* } } + +struct R3 { + double z; + R3(R3 A, R3 B) : z(B.z - A.z) {} + double norme() { return z; } +}; +struct TBoundaryEdge { + int *vertices[2]; + int &operator[](int i) { return *vertices[i]; } +}; +struct Mesh { + int vertices; + TBoundaryEdge *bedges; + int operator()(int &vv) { return &vv - &vertices; } + TBoundaryEdge be(int i) { return bedges[i]; } +}; +template <typename Data> struct GenericElement { + typedef typename Data::V Vertex; + static const int nv = Data::NbOfVertices; + Vertex *vertices[nv]; + double mes; + void set(int *iv, Vertex *v0) { + for (int i = 0; i < nv; ++i) + vertices[i] = v0 + iv[i]; + mes = Data::mesure(vertices); + } +}; +struct DataSeg3 { + static const int NbOfVertices = 2; + typedef R3 V; + static double mesure(V *pv[]) { return R3(*pv[0], *pv[1]).norme(); } +}; +struct MeshS { + MeshS(); +}; +template <class> struct Movemesh_Op { void foo(Mesh, DataSeg3::V *) const; }; +template <> void Movemesh_Op<int>::foo(Mesh pTh, DataSeg3::V *v0) const { + GenericElement<DataSeg3> *bS = new GenericElement<DataSeg3>[8]; + for (int ibe = 0; ibe < 8; ibe++) { + TBoundaryEdge K(pTh.be(ibe)); + int iv[2]; + for (int i = 0; i < 2; i++) { + int &__trans_tmp_2 = K[i]; + iv[i] = pTh(__trans_tmp_2); + } + bS[ibe].set(iv, v0); + } + MeshS T_Th; +} diff --git a/gcc/testsuite/g++.target/loongarch/pr106828.C b/gcc/testsuite/g++.target/loongarch/pr106828.C new file mode 100644 index 0000000..190c1db --- /dev/null +++ b/gcc/testsuite/g++.target/loongarch/pr106828.C @@ -0,0 +1,4 @@ +/* { dg-do-preprocess } */ +/* { dg-options "-mabi=lp64d -fsanitize=address" } */ + +/* Tests whether the compiler supports compile option '-fsanitize=address'. */ diff --git a/gcc/testsuite/gcc.dg/analyzer/data-model-1.c b/gcc/testsuite/gcc.dg/analyzer/data-model-1.c index 4318191..d8930d1 100644 --- a/gcc/testsuite/gcc.dg/analyzer/data-model-1.c +++ b/gcc/testsuite/gcc.dg/analyzer/data-model-1.c @@ -624,8 +624,7 @@ void test_29a (struct coord p[]) __analyzer_eval (q[-2].y == 107025); /* { dg-warning "TRUE" } */ q -= 2; - __analyzer_eval (q == &p[7]); /* { dg-warning "UNKNOWN" } */ - // TODO: make this be TRUE + __analyzer_eval (q == &p[7]); /* { dg-warning "TRUE" } */ __analyzer_eval (q->x == 107024); /* { dg-warning "TRUE" } */ __analyzer_eval (q->y == 107025); /* { dg-warning "TRUE" } */ diff --git a/gcc/testsuite/gcc.dg/analyzer/flexible-array-member-1.c b/gcc/testsuite/gcc.dg/analyzer/flexible-array-member-1.c new file mode 100644 index 0000000..2df085a --- /dev/null +++ b/gcc/testsuite/gcc.dg/analyzer/flexible-array-member-1.c @@ -0,0 +1,100 @@ +#include <stdlib.h> +#include <string.h> + +struct str { + size_t len; + char data[]; +}; + +struct str * +test_const_size (void) +{ + struct str *str = malloc(sizeof(str) + 10); + if (str) { + str->len = 10; + memset(str->data, 'x', 10); + return str; + } + return NULL; +} + +struct str * +test_const_size_oob_1 (void) +{ + /* Forgetting to add space for the trailing array. */ + struct str *str = malloc(sizeof(str)); + if (str) { + str->len = 10; + memset(str->data, 'x', 10); /* { dg-warning "heap-based buffer overflow" "Wanalyzer-out-of-bounds" } */ + /* { dg-warning "'memset' writing 10 bytes into a region of size 0 overflows the destination" "Wstringop-overflow" { target *-*-* } .-1 } */ + return str; + } + return NULL; +} + +struct str * +test_const_size_oob_2 (void) +{ + struct str *str = malloc(sizeof(str) + 10); + if (str) { + str->len = 10; + /* Using the wrong size here. */ + memset(str->data, 'x', 11); /* { dg-warning "heap-based buffer overflow" "Wanalyzer-out-of-bounds" } */ + /* { dg-warning "'memset' writing 11 bytes into a region of size 10 overflows the destination" "Wstringop-overflow" { target *-*-* } .-1 } */ + return str; + } + return NULL; +} + +struct str * +test_symbolic_size (size_t len) +{ + struct str *str = malloc(sizeof(str) + len); + if (str) { + str->len = len; + memset(str->data, 'x', len); + return str; + } + return NULL; +} + +struct str * +test_symbolic_size_oob (size_t len) +{ + /* Forgetting to add space for the trailing array. */ + struct str *str = malloc(sizeof(str)); + if (str) { + str->len = len; + memset(str->data, 'x', len); /* { dg-warning "heap-based buffer overflow" "PR analyzer/98247" { xfail *-*-* } } */ + // TODO(xfail): we don't yet complain about this case, which occurs when len > 0 + return str; + } + return NULL; +} + +struct str * +test_symbolic_size_with_terminator (size_t len) +{ + struct str *str = malloc(sizeof(str) + len + 1); + if (str) { + str->len = len; + memset(str->data, 'x', len); + str->data[len] = '\0'; + return str; + } + return NULL; +} + +struct str * +test_symbolic_size_with_terminator_oob (size_t len) +{ + /* Forgetting to add 1 for the terminator. */ + struct str *str = malloc(sizeof(str) + len); + if (str) { + str->len = len; + memset(str->data, 'x', len); + str->data[len] = '\0'; /* { dg-warning "heap-based buffer overflow" } */ + return str; + } + return NULL; +} diff --git a/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-5.c b/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-5.c new file mode 100644 index 0000000..7dc0bc5 --- /dev/null +++ b/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-5.c @@ -0,0 +1,156 @@ +/* { dg-additional-options "-Wno-unused-but-set-variable" } */ + +#include <string.h> +#include <stdio.h> +#include <stdlib.h> +#include <alloca.h> +#include <stdint.h> + +/* Tests with symbolic values. */ + +void test1 (size_t size) +{ + char *buf = __builtin_malloc (size); + if (!buf) return; + + buf[size] = '\0'; /* { dg-warning "overflow" } */ + free (buf); +} + +void test2 (size_t size) +{ + char *buf = __builtin_malloc (size); + if (!buf) return; + + buf[size + 1] = '\0'; /* { dg-warning "overflow" } */ + free (buf); +} + +void test3 (size_t size, size_t op) +{ + char *buf = __builtin_malloc (size); + if (!buf) return; + + buf[size + op] = '\0'; /* { dg-warning "overflow" } */ + free (buf); +} + +void test4 (size_t size, unsigned short s) +{ + char *buf = __builtin_alloca (size); + buf[size + s] = '\0'; /* { dg-warning "overflow" } */ +} + +void test5 (size_t size) +{ + int32_t *buf = __builtin_alloca (4 * size); + buf[size] = 42; /* { dg-warning "overflow" } */ +} + +void test6 (size_t size) +{ + int32_t *buf = __builtin_alloca (4 * size); + memset (buf, 0, 4 * size); + int32_t last = *(buf + 4 * size); /* { dg-warning "overread" } */ +} + +void test7 (size_t size) +{ + int32_t *buf = __builtin_alloca (4 * size + 3); /* { dg-warning "allocated buffer size is not a multiple of the pointee's size" } */ + buf[size] = 42; /* { dg-warning "overflow" } */ +} + +/* Test where the offset itself is not out-of-bounds + but multiple bytes are read. */ + +void test8 (size_t size, size_t offset) +{ + char src[size]; + char dst[size]; + memcpy (dst, src, size + offset); /* { dg-line test8 } */ + /* { dg-warning "overread" "warning" { target *-*-* } test8 } */ + /* { dg-warning "overflow" "warning" { target *-*-* } test8 } */ +} + +void test9 (size_t size, size_t offset) +{ + int32_t src[size]; + int32_t dst[size]; + memcpy (dst, src, 4 * size + 1); /* { dg-line test9 } */ + /* { dg-warning "overread" "warning" { target *-*-* } test9 } */ + /* { dg-warning "overflow" "warning" { target *-*-* } test9 } */ +} + +/* Test for no false-positives. */ + +void test10 (size_t size) +{ + int32_t buf[4 * size]; + /* 4 * size is smaller than 4 * 4 * size. */ + buf[size] = 42; +} + +void test11 (size_t size) +{ + int32_t *buf = __builtin_alloca (4 * size + 5); /* { dg-warning "allocated buffer size is not a multiple of the pointee's size" } */ + buf[size] = 42; +} + +void test12 (size_t size, size_t offset) +{ + int buf[size]; + buf[offset] = 42; +} + +void test13 (size_t size, int offset) +{ + int buf[size]; + /* We don't know whether offset is positive or not. */ + buf[size + offset] = 42; +} + +void test14 (size_t size, size_t offset, size_t offset2) +{ + int buf[size]; + /* We don't know whether offset > offset2. */ + buf[size + offset - offset2] = 42; +} + +void test15 (size_t a, size_t b) +{ + int buf[a * b]; + /* We can't reason about a*b < a+b either. */ + buf[a + b] = 42; +} + +/* Misc. */ + +char *test98 (const char *x, const char *y) +{ + size_t len_x = __builtin_strlen (x); + size_t len_y = __builtin_strlen (y); + size_t sz = len_x + len_y + 1; + char *result = __builtin_malloc (sz); + if (!result) + return NULL; + __builtin_memcpy (result, x, len_x); + __builtin_memcpy (result + len_x, y, len_y); + result[len_x + len_y] = '\0'; + return result; +} + +char *test99 (const char *x, const char *y) +{ + size_t len_x = __builtin_strlen (x); + size_t len_y = __builtin_strlen (y); + /* BUG (root cause): forgot to add 1 for terminator. */ + size_t sz = len_x + len_y; + char *result = __builtin_malloc (sz); + if (!result) + return NULL; + __builtin_memcpy (result, x, len_x); + __builtin_memcpy (result + len_x, y, len_y); + /* BUG (symptom): off-by-one out-of-bounds write to heap. */ + result[len_x + len_y] = '\0'; /* { dg-warning "overflow" } */ + return result; +} diff --git a/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-realloc-grow.c b/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-realloc-grow.c new file mode 100644 index 0000000..707611e --- /dev/null +++ b/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-realloc-grow.c @@ -0,0 +1,87 @@ +/* { dg-additional-options "-Wno-analyzer-too-complex" } */ + +/* Reduced from gnulib/read-file.c. + + Tests that there is no false-positive on + realloc when the buffer is growing. */ + +#include <stdlib.h> + +/* Indicate that the file is treated as binary. */ +#define RF_BINARY 0x1 + +#include <stdio.h> +#include <stdint.h> +#include <string.h> +#include <errno.h> + +char * +fread_file (FILE *stream, int flags, size_t *length) +{ + char *buf = NULL; + size_t alloc = BUFSIZ; + + if (!(buf = malloc (alloc))) + return NULL; /* errno is ENOMEM. */ + + { + size_t size = 0; /* number of bytes read so far */ + int save_errno; + + for (;;) + { + /* This reads 1 more than the size of a regular file + so that we get eof immediately. */ + size_t requested = alloc - size; + size_t count = fread (buf + size, 1, requested, stream); + size += count; + + { + char *new_buf; + + if (alloc < PTRDIFF_MAX - alloc / 2) + alloc = alloc + alloc / 2; + else + alloc = PTRDIFF_MAX; + + if (!(new_buf = realloc (buf, alloc))) + { + save_errno = errno; + break; + } + + buf = new_buf; + } + } + + free (buf); + errno = save_errno; + return NULL; + } +} + +/* Open and read the contents of FILENAME, and return a newly + allocated string with the content, and set *LENGTH to the length of + the string. The string is zero-terminated, but the terminating + zero byte is not counted in *LENGTH. On errors, *LENGTH is + undefined, errno preserves the values set by system functions (if + any), and NULL is returned. + If the RF_BINARY flag is set in FLAGS, the file is opened in binary + mode. If the RF_SENSITIVE flag is set in FLAGS, the memory buffer + internally allocated will be cleared upon failure. */ +char * +read_file (const char *filename, int flags, size_t *length) +{ + const char *mode = (flags & RF_BINARY) ? "rbe" : "re"; + FILE *stream = fopen (filename, mode); + char *out; + + if (!stream) + return NULL; + + out = fread_file (stream, flags, length); + + fclose (stream); + + return out; +} diff --git a/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-zero.c b/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-zero.c new file mode 100644 index 0000000..201ca00 --- /dev/null +++ b/gcc/testsuite/gcc.dg/analyzer/out-of-bounds-zero.c @@ -0,0 +1,67 @@ +/* { dg-additional-options "-Wno-stringop-overflow"} */ +/* -Wstringop-overflow= triggers on test5. */ + +#include <stdint.h> +#include <stdlib.h> + +void test1 (void) +{ + int32_t buf[1]; + /* Zero bytes written on non-zero allocation. */ + __builtin_memset (buf, 0, 0); +} + +void test2 (void) +{ + /* ISO C forbids zero-size arrays but GCC compiles this to an + zero-sized array without -Wpedantic. */ + int32_t buf[0]; + /* Write on zero capacity. */ + __builtin_memset (buf, 0, sizeof (int32_t)); /* { dg-line test2 } */ + + /* { dg-warning "overflow" "warning" { target *-*-* } test2 } */ + /* { dg-message "from byte 0 till byte 3" "final event" { target *-*-* } test2 } */ +} + +void test3 (void) +{ + int32_t buf[0]; + /* Zero bytes written on zero capacity. */ + __builtin_memset (buf, 0, 0); +} + +void test4 (void) +{ + int32_t *buf = malloc (sizeof (int32_t)); + if (!buf) + return; + + /* Zero bytes written on non-zero allocation. */ + __builtin_memset (buf, 0, 0); + free (buf); +} + +void test5 (void) +{ + int32_t *buf = malloc (0); + if (!buf) + return; + + /* Write on zero capacity. */ + __builtin_memset (buf, 0, sizeof (int32_t)); /* { dg-line test5 } */ + free (buf); + + /* { dg-warning "overflow" "warning" { target *-*-* } test5 } */ + /* { dg-message "from byte 0 till byte 3" "final event" { target *-*-* } test5 } */ +} + +void test6 (void) +{ + int32_t *buf = malloc (0); + if (!buf) + return; + + /* Zero bytes written on zero capacity. */ + __builtin_memset (buf, 0, 0); + free (buf); +} diff --git a/gcc/testsuite/gcc.dg/analyzer/pr106845.c b/gcc/testsuite/gcc.dg/analyzer/pr106845.c new file mode 100644 index 0000000..528c7b3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/analyzer/pr106845.c @@ -0,0 +1,11 @@ +int buf_size; + +int +main (void) +{ + char buf[buf_size]; + + __builtin_memset (&buf[1], 0, buf_size); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/analyzer/symbolic-gt-1.c b/gcc/testsuite/gcc.dg/analyzer/symbolic-gt-1.c new file mode 100644 index 0000000..140abce --- /dev/null +++ b/gcc/testsuite/gcc.dg/analyzer/symbolic-gt-1.c @@ -0,0 +1,76 @@ +#include <string.h> +#include "analyzer-decls.h" + +/* Test GT_EXPR comparison of symbolic values. */ + +void test1 (size_t size) +{ + size_t a = 4 * size + 1; + size_t b = 4 * size; + __analyzer_eval (a > b); /* { dg-warning "TRUE" } */ +} + +void test2 (size_t size, size_t offset) +{ + size_t a = size + offset; + size_t b = size; + __analyzer_eval (a > b); /* { dg-warning "TRUE" } */ +} + +void test3 (size_t size, size_t offset) +{ + size_t a = size * offset; + size_t b = size; + __analyzer_eval (a > b); /* { dg-warning "TRUE" } */ +} + +void test4 (size_t size) +{ + size_t op = -1; + size_t a = size + op; + size_t b = size; + __analyzer_eval (a > b); /* { dg-warning "UNKNOWN" } */ +} + +void test5 (size_t size) +{ + size_t a = size - 1; + size_t b = size; + __analyzer_eval (a > b); /* { dg-warning "UNKNOWN" } */ +} + +void test6 (size_t size, int offset) +{ + /* OFFSET is a symbolic integer, thus could be negative. */ + size_t a = size + offset; + size_t b = size; + __analyzer_eval (a > b); /* { dg-warning "UNKNOWN" } */ +} + +void test7 (size_t size, size_t mul) +{ + size_t a = mul * size + 1; + size_t b = mul * size; + __analyzer_eval (a > b); /* { dg-warning "TRUE" } */ +} + +void test8 (size_t size) +{ + size_t a = size - 5; + size_t b = size - 1; + __analyzer_eval (a > b); /* { dg-warning "UNKNOWN" } */ +} + +void test9 (size_t size) +{ + size_t a = size + 1; + size_t b = size + 2; + __analyzer_eval (a > b); /* { dg-warning "UNKNOWN" } */ +} + +void test10 (size_t size) +{ + size_t a = size + 2; + size_t b = size + 1; + __analyzer_eval (a > b); /* { dg-warning "TRUE" } */ +} diff --git a/gcc/testsuite/gcc.dg/c11-keywords-1.c b/gcc/testsuite/gcc.dg/c11-keywords-1.c new file mode 100644 index 0000000..974ccfc --- /dev/null +++ b/gcc/testsuite/gcc.dg/c11-keywords-1.c @@ -0,0 +1,11 @@ +/* Test new C2x keywords not keywords in C11. */ +/* { dg-do compile } */ +/* { dg-options "-std=c11 -pedantic-errors" } */ + +int alignas; +int alignof; +int bool; +int false; +int true; +int static_assert; +int thread_local; diff --git a/gcc/testsuite/gcc.dg/c11-unreachable-1.c b/gcc/testsuite/gcc.dg/c11-unreachable-1.c new file mode 100644 index 0000000..28e4839 --- /dev/null +++ b/gcc/testsuite/gcc.dg/c11-unreachable-1.c @@ -0,0 +1,9 @@ +/* Test unreachable not defined in <stddef.h> for C11. */ +/* { dg-do preprocess } */ +/* { dg-options "-std=c11 -pedantic-errors" } */ + +#include <stddef.h> + +#ifdef unreachable +#error "unreachable defined" +#endif diff --git a/gcc/testsuite/gcc.dg/c2x-align-1.c b/gcc/testsuite/gcc.dg/c2x-align-1.c new file mode 100644 index 0000000..25dbd62 --- /dev/null +++ b/gcc/testsuite/gcc.dg/c2x-align-1.c @@ -0,0 +1,41 @@ +/* Test C2x alignment support. Test valid code. */ +/* { dg-do compile } */ +/* { dg-options "-std=c2x -pedantic-errors" } */ + +#include <stddef.h> + +alignas (alignof (max_align_t)) char c; +extern alignas (max_align_t) char c; +extern char c; + +extern alignas (max_align_t) short s; +alignas (max_align_t) short s; + +alignas (int) int i; +extern int i; + +alignas (max_align_t) long l; + +alignas (max_align_t) long long ll; + +alignas (max_align_t) float f; + +alignas (max_align_t) double d; + +alignas (max_align_t) _Complex long double cld; + +alignas (0) alignas (int) alignas (char) char ca[10]; + +alignas ((int) alignof (max_align_t) + 0) int x; + +enum e { E = alignof (max_align_t) }; +alignas (E) int y; + +void +func (void) +{ + alignas (max_align_t) long long auto_ll; +} + +/* Valid, but useless. */ +alignas (0) struct s; /* { dg-warning "useless" } */ diff --git a/gcc/testsuite/gcc.dg/c2x-align-6.c b/gcc/testsuite/gcc.dg/c2x-align-6.c new file mode 100644 index 0000000..8559a58 --- /dev/null +++ b/gcc/testsuite/gcc.dg/c2x-align-6.c @@ -0,0 +1,8 @@ +/* Test C2x alignof returning minimum alignment for a type. */ +/* { dg-do run } */ +/* { dg-options "-std=c2x -pedantic-errors" } */ + +#define _Alignas alignas +#define _Alignof alignof + +#include "c11-align-6.c" diff --git a/gcc/testsuite/gcc.dg/c2x-bool-1.c b/gcc/testsuite/gcc.dg/c2x-bool-1.c index b64da1f..992fb31 100644 --- a/gcc/testsuite/gcc.dg/c2x-bool-1.c +++ b/gcc/testsuite/gcc.dg/c2x-bool-1.c @@ -11,16 +11,16 @@ extern void abort (void); extern void exit (int); extern int strcmp (const char *, const char *); -#if false - 1 < 0 -#error "false signed in #if" +#if false - 1 >= 0 +#error "false unsigned in #if" #endif #if false != 0 #error "false not 0 in #if" #endif -#if true - 2 < 0 -#error "true signed in #if" +#if true - 2 >= 0 +#error "true unsigned in #if" #endif #if true != 1 @@ -30,20 +30,14 @@ extern int strcmp (const char *, const char *); int main (void) { - if (strcmp (str (bool), "_Bool") != 0) - abort (); if (_Generic (true, _Bool : 1) != 1) abort (); if (true != 1) abort (); - if (strcmp (str (true), "((_Bool)+1u)") != 0) - abort (); if (_Generic (false, _Bool : 1) != 1) abort (); if (false != 0) abort (); - if (strcmp (str (false), "((_Bool)+0u)") != 0) - abort (); if (strcmp (str (__bool_true_false_are_defined), "1") != 0) abort (); exit (0); diff --git a/gcc/testsuite/gcc.dg/c2x-bool-2.c b/gcc/testsuite/gcc.dg/c2x-bool-2.c new file mode 100644 index 0000000..4edb34e --- /dev/null +++ b/gcc/testsuite/gcc.dg/c2x-bool-2.c @@ -0,0 +1,42 @@ +/* Test bool, true and false keywords in C2x. */ +/* { dg-do run } */ +/* { dg-options "-std=c2x -pedantic-errors" } */ + +extern void abort (void); +extern void exit (int); + +#if false - 1 >= 0 +#error "false unsigned in #if" +#endif + +#if false != 0 +#error "false not 0 in #if" +#endif + +#if true - 2 >= 0 +#error "true unsigned in #if" +#endif + +#if true != 1 +#error "true not 1 in #if" +#endif + +extern bool b; +extern _Bool b; + +_Static_assert (false == 0); +_Static_assert (true == 1); + +int +main (void) +{ + if (_Generic (true, bool : 1) != 1) + abort (); + if (true != 1) + abort (); + if (_Generic (false, bool : 1) != 1) + abort (); + if (false != 0) + abort (); + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/c2x-static-assert-3.c b/gcc/testsuite/gcc.dg/c2x-static-assert-3.c new file mode 100644 index 0000000..5d84a6a --- /dev/null +++ b/gcc/testsuite/gcc.dg/c2x-static-assert-3.c @@ -0,0 +1,6 @@ +/* Test C2x static assertions. static_assert keyword. */ +/* { dg-do compile } */ +/* { dg-options "-std=c2x -pedantic" } */ + +static_assert (1); +static_assert (1, "message"); diff --git a/gcc/testsuite/gcc.dg/c2x-static-assert-4.c b/gcc/testsuite/gcc.dg/c2x-static-assert-4.c new file mode 100644 index 0000000..b3bcfb4 --- /dev/null +++ b/gcc/testsuite/gcc.dg/c2x-static-assert-4.c @@ -0,0 +1,6 @@ +/* Test C2x static assertions. static_assert keyword. Failed assertions. */ +/* { dg-do compile } */ +/* { dg-options "-std=c2x -pedantic" } */ + +static_assert (0); /* { dg-error "static assertion failed" } */ +static_assert (0, "message"); /* { dg-error "message" } */ diff --git a/gcc/testsuite/gcc.dg/c2x-thread-local-1.c b/gcc/testsuite/gcc.dg/c2x-thread-local-1.c new file mode 100644 index 0000000..e1917bd --- /dev/null +++ b/gcc/testsuite/gcc.dg/c2x-thread-local-1.c @@ -0,0 +1,6 @@ +/* Test C2x thread_local keyword. */ +/* { dg-do compile } */ +/* { dg-options "-std=c2x -pedantic-errors" } */ + +thread_local int a; +thread_local void f (void); /* { dg-error "storage class" } */ diff --git a/gcc/testsuite/gcc.dg/c2x-unreachable-1.c b/gcc/testsuite/gcc.dg/c2x-unreachable-1.c new file mode 100644 index 0000000..468f1f8 --- /dev/null +++ b/gcc/testsuite/gcc.dg/c2x-unreachable-1.c @@ -0,0 +1,29 @@ +/* Test unreachable in <stddef.h> for C2x. */ +/* { dg-do run } */ +/* { dg-options "-std=c2x -pedantic-errors -O2" } */ + +#include <stddef.h> + +#ifndef unreachable +#error "unreachable not defined" +#endif + +extern void *p; +extern __typeof__ (unreachable ()) *p; + +volatile int x = 1; + +extern void not_defined (void); + +extern void exit (int); + +int +main () +{ + if (x == 2) + { + unreachable (); + not_defined (); + } + exit (0); +} diff --git a/gcc/testsuite/gcc.dg/plugin/analyzer_kernel_plugin.c b/gcc/testsuite/gcc.dg/plugin/analyzer_kernel_plugin.c new file mode 100644 index 0000000..6ec08bf --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/analyzer_kernel_plugin.c @@ -0,0 +1,237 @@ +/* Proof-of-concept of a -fanalyzer plugin for the Linux kernel. */ +/* { dg-options "-g" } */ + +#include "gcc-plugin.h" +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "function.h" +#include "basic-block.h" +#include "gimple.h" +#include "gimple-iterator.h" +#include "diagnostic-core.h" +#include "graphviz.h" +#include "options.h" +#include "cgraph.h" +#include "tree-dfa.h" +#include "stringpool.h" +#include "convert.h" +#include "target.h" +#include "fold-const.h" +#include "tree-pretty-print.h" +#include "diagnostic-color.h" +#include "diagnostic-metadata.h" +#include "tristate.h" +#include "bitmap.h" +#include "selftest.h" +#include "function.h" +#include "json.h" +#include "analyzer/analyzer.h" +#include "analyzer/analyzer-logging.h" +#include "ordered-hash-map.h" +#include "options.h" +#include "cgraph.h" +#include "cfg.h" +#include "digraph.h" +#include "analyzer/supergraph.h" +#include "sbitmap.h" +#include "analyzer/call-string.h" +#include "analyzer/program-point.h" +#include "analyzer/store.h" +#include "analyzer/region-model.h" +#include "analyzer/call-info.h" + +int plugin_is_GPL_compatible; + +#if ENABLE_ANALYZER + +namespace ana { + +/* Implementation of "copy_from_user" and "copy_to_user". */ + +class copy_across_boundary_fn : public known_function +{ + public: + virtual bool untrusted_source_p () const = 0; + virtual bool untrusted_destination_p () const = 0; + + void impl_call_pre (const call_details &cd) const final override + { + region_model_manager *mgr = cd.get_manager (); + region_model *model = cd.get_model (); + region_model_context *ctxt = cd.get_ctxt (); + + const svalue *dest_sval = cd.get_arg_svalue (0); + const svalue *src_sval = cd.get_arg_svalue (1); + const svalue *num_bytes_sval = cd.get_arg_svalue (2); + + const region *dest_reg = model->deref_rvalue (dest_sval, + cd.get_arg_tree (0), + ctxt); + const region *src_reg = model->deref_rvalue (src_sval, + cd.get_arg_tree (1), + ctxt); + if (const svalue *bounded_sval + = model->maybe_get_copy_bounds (src_reg, num_bytes_sval)) + num_bytes_sval = bounded_sval; + + if (tree cst = num_bytes_sval->maybe_get_constant ()) + if (zerop (cst)) + /* No-op. */ + return; + + const region *sized_src_reg = mgr->get_sized_region (src_reg, + NULL_TREE, + num_bytes_sval); + + const svalue *copied_sval + = model->get_store_value (sized_src_reg, ctxt); + const region *sized_dest_reg = mgr->get_sized_region (dest_reg, + NULL_TREE, + num_bytes_sval); + + if (ctxt) + { + /* Bifurcate state, creating a "failure" out-edge. */ + ctxt->bifurcate (new copy_failure (cd)); + + /* The "unbifurcated" state is the "success" case. */ + copy_success success (cd, + sized_dest_reg, + copied_sval, + sized_src_reg, + untrusted_source_p (), + untrusted_destination_p ()); + success.update_model (model, NULL, ctxt); + } + } + + private: + class copy_success : public success_call_info + { + public: + copy_success (const call_details &cd, + const region *sized_dest_reg, + const svalue *copied_sval, + const region *sized_src_reg, + bool untrusted_source, + bool untrusted_destination) + : success_call_info (cd), + m_sized_dest_reg (sized_dest_reg), + m_copied_sval (copied_sval), + m_sized_src_reg (sized_src_reg), + m_untrusted_source (untrusted_source), + m_untrusted_destination (untrusted_destination) + {} + + bool update_model (region_model *model, + const exploded_edge *, + region_model_context *ctxt) const final override + { + call_details cd (get_call_details (model, ctxt)); + model->update_for_zero_return (cd, true); + model->set_value (m_sized_dest_reg, m_copied_sval, ctxt); + if (ctxt && m_untrusted_source) + model->mark_as_tainted (m_copied_sval, ctxt); + if (m_untrusted_destination) + model->maybe_complain_about_infoleak (m_sized_dest_reg, + m_copied_sval, + m_sized_src_reg, + ctxt); + return true; + } + + const region *m_sized_dest_reg; + const svalue *m_copied_sval; + const region *m_sized_src_reg; + bool m_untrusted_source; + bool m_untrusted_destination; + }; + + class copy_failure : public failed_call_info + { + public: + copy_failure (const call_details &cd) + : failed_call_info (cd) + {} + + bool update_model (region_model *model, + const exploded_edge *, + region_model_context *ctxt) const final override + { + call_details cd (get_call_details (model, ctxt)); + model->update_for_nonzero_return (cd); + /* Leave the destination region untouched. */ + return true; + } + }; +}; + +/* "copy_from_user". */ + +class known_function_copy_from_user : public copy_across_boundary_fn +{ +public: + bool untrusted_source_p () const final override + { + return true; + } + bool untrusted_destination_p () const final override + { + return false; + } +}; + +/* "copy_to_user". */ + +class known_function_copy_to_user : public copy_across_boundary_fn +{ +public: + bool untrusted_source_p () const final override + { + return false; + } + bool untrusted_destination_p () const final override + { + return true; + } +}; + +/* Callback handler for the PLUGIN_ANALYZER_INIT event. */ + +static void +kernel_analyzer_init_cb (void *gcc_data, void */*user_data*/) +{ + ana::plugin_analyzer_init_iface *iface + = (ana::plugin_analyzer_init_iface *)gcc_data; + LOG_SCOPE (iface->get_logger ()); + if (0) + inform (input_location, "got here: kernel_analyzer_init_cb"); + iface->register_known_function ("copy_from_user", + new known_function_copy_from_user ()); + iface->register_known_function ("copy_to_user", + new known_function_copy_to_user ()); +} + +} // namespace ana + +#endif /* #if ENABLE_ANALYZER */ + +int +plugin_init (struct plugin_name_args *plugin_info, + struct plugin_gcc_version *version) +{ +#if ENABLE_ANALYZER + const char *plugin_name = plugin_info->base_name; + if (0) + inform (input_location, "got here; %qs", plugin_name); + register_callback (plugin_info->base_name, + PLUGIN_ANALYZER_INIT, + ana::kernel_analyzer_init_cb, + NULL); /* void *user_data */ +#else + sorry_no_analyzer (); +#endif + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/analyzer_known_fns_plugin.c b/gcc/testsuite/gcc.dg/plugin/analyzer_known_fns_plugin.c new file mode 100644 index 0000000..060a308 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/analyzer_known_fns_plugin.c @@ -0,0 +1,201 @@ +/* Proof-of-concept of a -fanalyzer plugin to handle known functions. */ +/* { dg-options "-g" } */ + +#include "gcc-plugin.h" +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "function.h" +#include "basic-block.h" +#include "gimple.h" +#include "gimple-iterator.h" +#include "diagnostic-core.h" +#include "graphviz.h" +#include "options.h" +#include "cgraph.h" +#include "tree-dfa.h" +#include "stringpool.h" +#include "convert.h" +#include "target.h" +#include "fold-const.h" +#include "tree-pretty-print.h" +#include "diagnostic-color.h" +#include "diagnostic-metadata.h" +#include "tristate.h" +#include "bitmap.h" +#include "selftest.h" +#include "function.h" +#include "json.h" +#include "analyzer/analyzer.h" +#include "analyzer/analyzer-logging.h" +#include "ordered-hash-map.h" +#include "options.h" +#include "cgraph.h" +#include "cfg.h" +#include "digraph.h" +#include "analyzer/supergraph.h" +#include "sbitmap.h" +#include "analyzer/call-string.h" +#include "analyzer/program-point.h" +#include "analyzer/store.h" +#include "analyzer/region-model.h" +#include "analyzer/call-info.h" + +int plugin_is_GPL_compatible; + +#if ENABLE_ANALYZER + +namespace ana { + +/* Basic example of known fn behavior. */ + +class known_function_returns_42 : public known_function +{ +public: + void impl_call_pre (const call_details &cd) const final override + { + if (cd.get_lhs_type ()) + { + const svalue *result + = cd.get_manager ()->get_or_create_int_cst (cd.get_lhs_type (), 42); + cd.maybe_set_lhs (result); + } + } +}; + +/* Example of bifurcation, with a copy that can fail. */ + +class known_function_attempt_to_copy : public known_function +{ +public: + class copy_success : public success_call_info + { + public: + copy_success (const call_details &cd, + const region *sized_dest_reg, + const svalue *copied_sval) + : success_call_info (cd), + m_sized_dest_reg (sized_dest_reg), + m_copied_sval (copied_sval) + {} + + bool update_model (region_model *model, + const exploded_edge *, + region_model_context *ctxt) const final override + { + call_details cd (get_call_details (model, ctxt)); + model->update_for_zero_return (cd, true); + model->set_value (m_sized_dest_reg, m_copied_sval, ctxt); + return true; + } + + const region *m_sized_dest_reg; + const svalue *m_copied_sval; + const region *m_sized_src_reg; + }; + + class copy_failure : public failed_call_info + { + public: + copy_failure (const call_details &cd) + : failed_call_info (cd) + {} + + bool update_model (region_model *model, + const exploded_edge *, + region_model_context *ctxt) const final override + { + call_details cd (get_call_details (model, ctxt)); + model->update_for_nonzero_return (cd); + /* Leave the destination region untouched. */ + return true; + } + }; + + void impl_call_pre (const call_details &cd) const final override + { + region_model_manager *mgr = cd.get_manager (); + region_model *model = cd.get_model (); + + const svalue *dest_sval = cd.get_arg_svalue (0); + const svalue *src_sval = cd.get_arg_svalue (1); + const svalue *num_bytes_sval = cd.get_arg_svalue (2); + + const region *dest_reg = model->deref_rvalue (dest_sval, + cd.get_arg_tree (0), + cd.get_ctxt ()); + const region *src_reg = model->deref_rvalue (src_sval, + cd.get_arg_tree (1), + cd.get_ctxt ()); + if (const svalue * bounded_sval + = model->maybe_get_copy_bounds (src_reg, num_bytes_sval)) + num_bytes_sval = bounded_sval; + + if (tree cst = num_bytes_sval->maybe_get_constant ()) + if (zerop (cst)) + /* No-op. */ + return; + + const region *sized_src_reg = mgr->get_sized_region (src_reg, + NULL_TREE, + num_bytes_sval); + + const svalue *copied_sval + = model->get_store_value (sized_src_reg, cd.get_ctxt ()); + + const region *sized_dest_reg = mgr->get_sized_region (dest_reg, + NULL_TREE, + num_bytes_sval); + + if (cd.get_ctxt ()) + { + /* Bifurcate state, creating a "failure" out-edge. */ + cd.get_ctxt ()->bifurcate (new copy_failure (cd)); + + /* The "unbifurcated" state is the "success" case. */ + copy_success success (cd, + sized_dest_reg, + copied_sval); + success.update_model (model, NULL, cd.get_ctxt ()); + } + } +}; + +/* Callback handler for the PLUGIN_ANALYZER_INIT event. */ + +static void +known_fn_analyzer_init_cb (void *gcc_data, void */*user_data*/) +{ + ana::plugin_analyzer_init_iface *iface + = (ana::plugin_analyzer_init_iface *)gcc_data; + LOG_SCOPE (iface->get_logger ()); + if (0) + inform (input_location, "got here: known_fn_analyzer_init_cb"); + iface->register_known_function ("returns_42", + new known_function_returns_42 ()); + iface->register_known_function ("attempt_to_copy", + new known_function_attempt_to_copy ()); +} + +} // namespace ana + +#endif /* #if ENABLE_ANALYZER */ + +int +plugin_init (struct plugin_name_args *plugin_info, + struct plugin_gcc_version *version) +{ +#if ENABLE_ANALYZER + const char *plugin_name = plugin_info->base_name; + if (0) + inform (input_location, "got here; %qs", plugin_name); + register_callback (plugin_info->base_name, + PLUGIN_ANALYZER_INIT, + ana::known_fn_analyzer_init_cb, + NULL); /* void *user_data */ +#else + sorry_no_analyzer (); +#endif + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/copy_from_user-1.c b/gcc/testsuite/gcc.dg/plugin/copy_from_user-1.c new file mode 100644 index 0000000..a1415f3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/copy_from_user-1.c @@ -0,0 +1,45 @@ +typedef __SIZE_TYPE__ size_t; + +#define __user + +extern int copy_from_user(void *to, const void __user *from, long n) + __attribute__((access (write_only, 1, 3), + access (read_only, 2, 3) + )); + +#define EFAULT 14 +#define EINVAL 22 + +/* Taken from Linux: fs/binfmt_misc.c (GPL-2.0-only). */ + +int parse_command(const char __user *buffer, size_t count) +{ + char s[4]; + + if (count > 3) + return -EINVAL; + if (copy_from_user(s, buffer, count)) + return -EFAULT; + if (!count) + return 0; + if (s[count - 1] == '\n') /* { dg-bogus "uninit" } */ + count--; + if (count == 1 && s[0] == '0') /* { dg-bogus "uninit" } */ + return 1; + if (count == 1 && s[0] == '1') /* { dg-bogus "uninit" } */ + return 2; + if (count == 2 && s[0] == '-' && s[1] == '1') /* { dg-bogus "uninit" } */ + return 3; + return -EINVAL; +} + +/* Not using return value from copy_from_user. */ + +int test_2 (const char __user *buffer, size_t count) +{ + char s[4]; + if (count > 3) + return -EINVAL; + copy_from_user(s, buffer, count); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-1.c new file mode 100644 index 0000000..b4958e7 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-1.c @@ -0,0 +1,185 @@ +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include <string.h> + +#include "test-uaccess.h" + +typedef unsigned char u8; +typedef unsigned __INT16_TYPE__ u16; +typedef unsigned __INT32_TYPE__ u32; + +struct s1 +{ + u32 i; +}; + +void test_1a (void __user *dst, u32 a) +{ + struct s1 s; + s.i = a; + copy_to_user(dst, &s, sizeof (struct s1)); /* { dg-bogus "" } */ +} + +void test_1b (void __user *dst, u32 a) +{ + struct s1 s; + copy_to_user(dst, &s, sizeof (struct s1)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "4 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ +} + +void test_1c (void __user *dst, u32 a) +{ + struct s1 s; + memset (&s, 0, sizeof (struct s1)); + copy_to_user(dst, &s, sizeof (struct s1)); /* { dg-bogus "" } */ +} + +void test_1d (void __user *dst, u32 a) +{ + struct s1 s = {0}; + copy_to_user(dst, &s, sizeof (struct s1)); /* { dg-bogus "" } */ +} + +struct s2 +{ + u32 i; + u32 j; /* { dg-message "field 'j' is uninitialized \\(4 bytes\\)" } */ +}; + +void test_2a (void __user *dst, u32 a) +{ + struct s2 s; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 8 bytes" "capacity" { target *-*-* } .-1 } */ + s.i = a; + copy_to_user(dst, &s, sizeof (struct s2)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "4 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ +} + +void test_2b (void __user *dst, u32 a) +{ + struct s2 s; + s.i = a; + /* Copy with wrong size (only part of s2). */ + copy_to_user(dst, &s, sizeof (struct s1)); +} + +void test_2d (void __user *dst, u32 a) +{ + struct s2 s = {0}; + s.i = a; + copy_to_user(dst, &s, sizeof (struct s2)); /* { dg-bogus" } */ +} + +struct empty {}; + +void test_empty (void __user *dst) +{ + struct empty e; + copy_to_user(dst, &e, sizeof (struct empty)); +} + +union un_a +{ + u32 i; + u8 j; +}; + +/* As above, but in a different order. */ + +union un_b +{ + u8 j; + u32 i; +}; + +void test_union_1a (void __user *dst, u8 v) +{ + union un_a u; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 4 bytes" "capacity" { target *-*-* } .-1 } */ + u.j = v; + copy_to_user(dst, &u, sizeof (union un_a)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "3 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + /* { dg-message "bytes 1 - 3 are uninitialized" "note how much" { target *-*-* } .-2 } */ +} + +void test_union_1b (void __user *dst, u8 v) +{ + union un_b u; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 4 bytes" "capacity" { target *-*-* } .-1 } */ + u.j = v; + copy_to_user(dst, &u, sizeof (union un_b)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "3 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + /* { dg-message "bytes 1 - 3 are uninitialized" "note how much" { target *-*-* } .-2 } */ +} + +void test_union_2a (void __user *dst, u8 v) +{ + union un_a u = {0}; + u.j = v; + copy_to_user(dst, &u, sizeof (union un_a)); +} + +void test_union_2b (void __user *dst, u8 v) +{ + union un_b u = {0}; + u.j = v; + copy_to_user(dst, &u, sizeof (union un_b)); +} + +void test_union_3a (void __user *dst, u32 v) +{ + union un_a u; + u.i = v; + copy_to_user(dst, &u, sizeof (union un_a)); /* { dg-bogus "" } */ +} + +void test_union_3b (void __user *dst, u32 v) +{ + union un_b u; + u.i = v; + copy_to_user(dst, &u, sizeof (union un_b)); /* { dg-bogus "" } */ +} + +void test_union_4a (void __user *dst, u8 v) +{ + union un_a u = {0}; + copy_to_user(dst, &u, sizeof (union un_a)); /* { dg-bogus "" } */ +} + +void test_union_4b (void __user *dst, u8 v) +{ + union un_b u = {0}; + copy_to_user(dst, &u, sizeof (union un_b)); /* { dg-bogus "" } */ +} + +struct st_union_5 +{ + union { + u8 f1; + u32 f2; + } u; /* { dg-message "field 'u' is partially uninitialized" } */ +}; + +void test_union_5 (void __user *dst, u8 v) +{ + struct st_union_5 st; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 4 bytes" "capacity" { target *-*-* } .-1 } */ + + /* This write only initializes the u8 within the union "u", + leaving the remaining 3 bytes uninitialized. */ + st.u.f1 = v; + + copy_to_user (dst, &st, sizeof(st)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "3 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ +} + +void test_one_byte (void __user *dst) +{ + char src; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 1 byte" "capacity" { target *-*-* } .-1 } */ + + copy_to_user (dst, &src, sizeof(src)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "1 byte is uninitialized" "note how much" { target *-*-* } .-1 } */ +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-2.c b/gcc/testsuite/gcc.dg/plugin/infoleak-2.c new file mode 100644 index 0000000..252f8f2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-2.c @@ -0,0 +1,33 @@ +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include <string.h> + +#include "test-uaccess.h" + +typedef unsigned char u8; +typedef unsigned __INT16_TYPE__ u16; +typedef unsigned __INT32_TYPE__ u32; + +/* Coverage for the various singular and plural forms of bits, bytes, and fields vs padding. */ + +struct st +{ + u32 a; /* { dg-message "field 'a' is uninitialized \\(4 bytes\\)" } */ + int b:1; /* { dg-message "field 'b' is uninitialized \\(1 bit\\)" "field" } */ + /* { dg-message "padding after field 'b' is uninitialized \\(7 bits\\)" "padding" { target *-*-* } .-1 } */ + u8 d; /* { dg-message "field 'd' is uninitialized \\(1 byte\\)" } */ + int c:7; /* { dg-message "padding after field 'c' is uninitialized \\(9 bits\\)" } */ + u16 e; /* { dg-message "padding after field 'e' is uninitialized \\(2 bytes\\)" } */ +}; + +void test (void __user *dst, u16 v) +{ + struct st s; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 12 bytes" "capacity" { target *-*-* } .-1 } */ + /* { dg-message "suggest forcing zero-initialization by providing a '\\{0\\}' initializer" "fix-it" { target *-*-* } .-2 } */ + s.e = v; + copy_to_user(dst, &s, sizeof (struct st)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "10 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-3.c b/gcc/testsuite/gcc.dg/plugin/infoleak-3.c new file mode 100644 index 0000000..097a0d8 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-3.c @@ -0,0 +1,145 @@ +/* Verify that -Wanalyzer-exposure-through-uninit-copy doesn't get confused + if size argument to copy_to_user is an upper bound, rather than a + constant. */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include "../analyzer/analyzer-decls.h" + +typedef __SIZE_TYPE__ size_t; + +#include "test-uaccess.h" + +typedef unsigned __INT32_TYPE__ u32; + +/* min_t adapted from include/linux/kernel.h. */ + +#define min_t(type, x, y) ({ \ + type __min1 = (x); \ + type __min2 = (y); \ + __min1 < __min2 ? __min1: __min2; }) + +struct st +{ + u32 a; + u32 b; +}; + +/* Verify that we cope with min_t. */ + +void test_1_full_init (void __user *dst, u32 x, u32 y, unsigned long in_sz) +{ + struct st s; + s.a = x; + s.b = y; + unsigned long copy_sz = min_t(unsigned long, in_sz, sizeof(s)); + copy_to_user(dst, &s, copy_sz); /* { dg-bogus "exposure" } */ +} + +void test_1_partial_init (void __user *dst, u32 x, u32 y, unsigned long in_sz) +{ + struct st s; + s.a = x; + /* s.y not initialized. */ + unsigned long copy_sz = min_t(unsigned long, in_sz, sizeof(s)); + copy_to_user(dst, &s, copy_sz); /* { dg-warning "exposure" } */ +} + +/* Constant on LHS rather than RHS. */ + +void test_2_full_init (void __user *dst, u32 x, u32 y, unsigned long in_sz) +{ + struct st s; + s.a = x; + s.b = y; + unsigned long copy_sz = min_t(unsigned long, sizeof(s), in_sz); + copy_to_user(dst, &s, copy_sz); /* { dg-bogus "exposure" } */ +} + +void test_2_partial_init (void __user *dst, u32 x, u32 y, unsigned long in_sz) +{ + struct st s; + s.a = x; + /* s.y not initialized. */ + unsigned long copy_sz = min_t(unsigned long, sizeof(s), in_sz); + copy_to_user(dst, &s, copy_sz); /* { dg-warning "exposure" } */ +} + +/* min_t with various casts. */ + +void test_3_full_init (void __user *dst, u32 x, u32 y, int in_sz) +{ + struct st s; + s.a = x; + s.b = y; + int copy_sz = min_t(unsigned int, in_sz, sizeof(s)); + copy_to_user(dst, &s, copy_sz); /* { dg-bogus "exposure" } */ +} + +void test_3_partial_init (void __user *dst, u32 x, u32 y, int in_sz) +{ + struct st s; + s.a = x; + /* s.y not initialized. */ + int copy_sz = min_t(unsigned int, in_sz, sizeof(s)); + copy_to_user(dst, &s, copy_sz); /* { dg-warning "exposure" } */ +} + +/* Comparison against an upper bound. */ + +void test_4_full_init (void __user *dst, u32 x, u32 y, size_t in_sz) +{ + struct st s; + s.a = x; + s.b = y; + + size_t copy_sz = in_sz; + if (copy_sz > sizeof(s)) + copy_sz = sizeof(s); + + copy_to_user(dst, &s, copy_sz); /* { dg-bogus "exposure" } */ +} + +void test_4_partial_init (void __user *dst, u32 x, u32 y, size_t in_sz) +{ + struct st s; + s.a = x; + /* s.y not initialized. */ + + size_t copy_sz = in_sz; + if (copy_sz > sizeof(s)) + copy_sz = sizeof(s); + + copy_to_user(dst, &s, copy_sz); /* { dg-warning "exposure" } */ +} + +/* Comparison against an upper bound with casts. */ + +void test_5_full_init (void __user *dst, u32 x, u32 y, int in_sz) +{ + struct st s; + s.a = x; + s.b = y; + + int copy_sz = in_sz; + if (copy_sz > sizeof(s)) + copy_sz = sizeof(s); + copy_to_user(dst, &s, copy_sz); /* { dg-bogus "exposure" } */ +} + +/* Comparison against an upper bound with casts. */ + +void test_5_partial_init (void __user *dst, u32 x, u32 y, int in_sz) +{ + struct st s; + s.a = x; + /* s.y not initialized. */ + + int copy_sz = in_sz; + if (copy_sz > sizeof(s)) + copy_sz = sizeof(s); + + copy_to_user(dst, &s, copy_sz); /* { dg-warning "exposure" "" } */ +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2011-1078-1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2011-1078-1.c new file mode 100644 index 0000000..3616fbe --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2011-1078-1.c @@ -0,0 +1,138 @@ +/* "The sco_sock_getsockopt_old function in net/bluetooth/sco.c in the + Linux kernel before 2.6.39 does not initialize a certain structure, + which allows local users to obtain potentially sensitive information + from kernel stack memory via the SCO_CONNINFO option." + + Fixed e.g. by c4c896e1471aec3b004a693c689f60be3b17ac86 on linux-2.6.39.y + in linux-stable. */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include <string.h> + +typedef unsigned char __u8; +typedef unsigned short __u16; + +#include "test-uaccess.h" + +/* Adapted from include/asm-generic/uaccess.h. */ + +#define get_user(x, ptr) \ +({ \ + /* [...snip...] */ \ + __get_user_fn(sizeof (*(ptr)), ptr, &(x)); \ + /* [...snip...] */ \ +}) + +static inline int __get_user_fn(size_t size, const void __user *ptr, void *x) +{ + size = copy_from_user(x, ptr, size); + return size ? -1 : size; +} + +/* Adapted from include/linux/kernel.h. */ + +#define min_t(type, x, y) ({ \ + type __min1 = (x); \ + type __min2 = (y); \ + __min1 < __min2 ? __min1: __min2; }) + +/* Adapted from include/linux/net.h. */ + +struct socket { + /* [...snip...] */ + struct sock *sk; + /* [...snip...] */ +}; + +/* Adapted from include/net/bluetooth/sco.h. */ + +struct sco_conninfo { + __u16 hci_handle; + __u8 dev_class[3]; /* { dg-message "padding after field 'dev_class' is uninitialized \\(1 byte\\)" } */ +}; + +struct sco_conn { + + struct hci_conn *hcon; + /* [...snip...] */ +}; + +#define sco_pi(sk) ((struct sco_pinfo *) sk) + +struct sco_pinfo { + /* [...snip...] */ + struct sco_conn *conn; +}; + +/* Adapted from include/net/bluetooth/hci_core.h. */ + +struct hci_conn { + /* [...snip...] */ + __u16 handle; + /* [...snip...] */ + __u8 dev_class[3]; + /* [...snip...] */ +}; + +/* Adapted from sco_sock_getsockopt_old in net/bluetooth/sco.c. */ + +static int sco_sock_getsockopt_old_broken(struct socket *sock, int optname, char __user *optval, int __user *optlen) +{ + struct sock *sk = sock->sk; + /* [...snip...] */ + struct sco_conninfo cinfo; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 6 bytes" "capacity" { target *-*-* } .-1 } */ + /* Note: 40 bits of fields, padded to 48. */ + + int len, err = 0; + + /* [...snip...] */ + + if (get_user(len, optlen)) + return -1; + + /* [...snip...] */ + + /* case SCO_CONNINFO: */ + cinfo.hci_handle = sco_pi(sk)->conn->hcon->handle; + memcpy(cinfo.dev_class, sco_pi(sk)->conn->hcon->dev_class, 3); + + len = min_t(unsigned int, len, sizeof(cinfo)); + if (copy_to_user(optval, (char *)&cinfo, len)) /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" { target *-*-* } } */ + /* { dg-message "1 byte is uninitialized" "how much note" { target *-*-* } .-1 } */ + err = -1; + + /* [...snip...] */ +} + +static int sco_sock_getsockopt_fixed(struct socket *sock, int optname, char __user *optval, int __user *optlen) +{ + struct sock *sk = sock->sk; + /* [...snip...] */ + struct sco_conninfo cinfo; + /* Note: 40 bits of fields, padded to 48. */ + + int len, err = 0; + + /* [...snip...] */ + + if (get_user(len, optlen)) + return -1; + + /* [...snip...] */ + + /* case SCO_CONNINFO: */ + /* Infoleak fixed by this memset call. */ + memset(&cinfo, 0, sizeof(cinfo)); + cinfo.hci_handle = sco_pi(sk)->conn->hcon->handle; + memcpy(cinfo.dev_class, sco_pi(sk)->conn->hcon->dev_class, 3); + + len = min_t(unsigned int, len, sizeof(cinfo)); + if (copy_to_user(optval, (char *)&cinfo, len)) /* { dg-bogus "exposure" } */ + err = -1; + + /* [...snip...] */ +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2011-1078-2.c b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2011-1078-2.c new file mode 100644 index 0000000..2096bda --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2011-1078-2.c @@ -0,0 +1,46 @@ +/* Simplified versions of infoleak-CVE-2011-1078-1.c. */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include <string.h> + +typedef unsigned char __u8; +typedef unsigned short __u16; + +#include "test-uaccess.h" + +/* Adapted from include/net/bluetooth/sco.h. */ + +struct sco_conninfo { + __u16 hci_handle; + __u8 dev_class[3]; /* { dg-message "padding after field 'dev_class' is uninitialized \\(1 byte\\)" } */ +}; + +/* Adapted from sco_sock_getsockopt_old in net/bluetooth/sco.c. */ + +int test_1 (char __user *optval, const struct sco_conninfo *in) +{ + struct sco_conninfo cinfo; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 6 bytes" "capacity" { target *-*-* } .-1 } */ + /* Note: 40 bits of fields, padded to 48. */ + + cinfo.hci_handle = in->hci_handle; + memcpy(cinfo.dev_class, in->dev_class, 3); + + copy_to_user(optval, &cinfo, sizeof(cinfo)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "1 byte is uninitialized" "how much note" { target *-*-* } .-1 } */ +} + +int test_2 (char __user *optval, const struct sco_conninfo *in) +{ + struct sco_conninfo cinfo; + /* Note: 40 bits of fields, padded to 48. */ + + memset(&cinfo, 0, sizeof(cinfo)); + cinfo.hci_handle = in->hci_handle; + memcpy(cinfo.dev_class, in->dev_class, 3); + + copy_to_user(optval, &cinfo, sizeof(cinfo)); /* { dg-bogus "" } */ +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2014-1446-1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2014-1446-1.c new file mode 100644 index 0000000..2726a9c --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2014-1446-1.c @@ -0,0 +1,117 @@ +/* "The yam_ioctl function in drivers/net/hamradio/yam.c in the Linux kernel + before 3.12.8 does not initialize a certain structure member, which allows + local users to obtain sensitive information from kernel memory by + leveraging the CAP_NET_ADMIN capability for an SIOCYAMGCFG ioctl call." + + Fixed e.g. by e7834c71c2cacc621ddc64bd71f83ef2054f6539 on linux-3.12.y + in linux-stable. */ + +#include <string.h> + +#include "test-uaccess.h" + +/* Adapted from include/linux/yam.h */ + +struct yamcfg { + unsigned int mask; /* Mask of commands */ + unsigned int iobase; /* IO Base of COM port */ + unsigned int irq; /* IRQ of COM port */ + unsigned int bitrate; /* Bit rate of radio port */ + unsigned int baudrate; /* Baud rate of the RS232 port */ + unsigned int txdelay; /* TxDelay */ + unsigned int txtail; /* TxTail */ + unsigned int persist; /* Persistence */ + unsigned int slottime; /* Slottime */ + unsigned int mode; /* mode 0 (simp), 1(Dupl), 2(Dupl+delay) */ + unsigned int holddly; /* PTT delay in FullDuplex 2 mode */ +}; + +struct yamdrv_ioctl_cfg { + int cmd; /* { dg-message "field 'cmd' is uninitialized \\(4 bytes\\)" } */ + struct yamcfg cfg; +}; + +/* Adapted from include/asm-generic/errno-base.h */ + +#define EFAULT 14 /* Bad address */ + +/* Adapted from drivers/net/hamradio/yam.c */ + +struct yam_port { + /* [...snip...] */ + + int bitrate; + int baudrate; + int iobase; + int irq; + int dupmode; + + /* [...snip...] */ + + int txd; /* tx delay */ + int holdd; /* duplex ptt delay */ + int txtail; /* txtail delay */ + int slot; /* slottime */ + int pers; /* persistence */ + + /* [...snip...] */ +}; + +/* Broken version, leaving yi.cmd uninitialized. */ + +static int yam_ioctl(/* [...snip...] */ + void __user *dst, struct yam_port *yp) +{ + struct yamdrv_ioctl_cfg yi; /* { dg-message "region created on stack here" "memspace event" } */ + /* { dg-message "capacity: 48 bytes" "capacity event" { target *-*-* } .-1 } */ + + /* [...snip...] */ + + /* case SIOCYAMGCFG: */ + yi.cfg.mask = 0xffffffff; + yi.cfg.iobase = yp->iobase; + yi.cfg.irq = yp->irq; + yi.cfg.bitrate = yp->bitrate; + yi.cfg.baudrate = yp->baudrate; + yi.cfg.mode = yp->dupmode; + yi.cfg.txdelay = yp->txd; + yi.cfg.holddly = yp->holdd; + yi.cfg.txtail = yp->txtail; + yi.cfg.persist = yp->pers; + yi.cfg.slottime = yp->slot; + if (copy_to_user(dst, &yi, sizeof(struct yamdrv_ioctl_cfg))) /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "4 bytes are uninitialized" "how much note" { target *-*-* } .-1 } */ + return -EFAULT; + /* [...snip...] */ + + return 0; +} + +/* Fixed version, with a memset. */ + +static int yam_ioctl_fixed(/* [...snip...] */ + void __user *dst, struct yam_port *yp) +{ + struct yamdrv_ioctl_cfg yi; + + /* [...snip...] */ + + /* case SIOCYAMGCFG: */ + memset(&yi, 0, sizeof(yi)); + yi.cfg.mask = 0xffffffff; + yi.cfg.iobase = yp->iobase; + yi.cfg.irq = yp->irq; + yi.cfg.bitrate = yp->bitrate; + yi.cfg.baudrate = yp->baudrate; + yi.cfg.mode = yp->dupmode; + yi.cfg.txdelay = yp->txd; + yi.cfg.holddly = yp->holdd; + yi.cfg.txtail = yp->txtail; + yi.cfg.persist = yp->pers; + yi.cfg.slottime = yp->slot; + if (copy_to_user(dst, &yi, sizeof(struct yamdrv_ioctl_cfg))) /* { dg-bogus "" } */ + return -EFAULT; + /* [...snip...] */ + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2017-18549-1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2017-18549-1.c new file mode 100644 index 0000000..8a1c816 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2017-18549-1.c @@ -0,0 +1,105 @@ +/* "An issue was discovered in drivers/scsi/aacraid/commctrl.c in the + Linux kernel before 4.13. There is potential exposure of kernel stack + memory because aac_send_raw_srb does not initialize the reply structure." + + Fixed e.g. by 342ffc26693b528648bdc9377e51e4f2450b4860 on linux-4.13.y + in linux-stable. + + This is a very simplified version of that code (before and after the fix). */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include <string.h> + +typedef unsigned int __u32; +typedef unsigned int u32; +typedef unsigned char u8; + +#include "test-uaccess.h" + +/* Adapted from include/uapi/linux/types.h */ + +#define __bitwise +typedef __u32 __bitwise __le32; + +/* Adapted from drivers/scsi/aacraid/aacraid.h */ + +#define AAC_SENSE_BUFFERSIZE 30 + +struct aac_srb_reply +{ + __le32 status; + __le32 srb_status; + __le32 scsi_status; + __le32 data_xfer_length; + __le32 sense_data_size; + u8 sense_data[AAC_SENSE_BUFFERSIZE]; /* { dg-message "padding after field 'sense_data' is uninitialized \\(2 bytes\\)" } */ +}; + +#define ST_OK 0 +#define SRB_STATUS_SUCCESS 0x01 + +/* Adapted from drivers/scsi/aacraid/commctrl.c */ + +static int aac_send_raw_srb(/* [...snip...] */ + void __user *user_reply) +{ + u32 byte_count = 0; + + /* [...snip...] */ + + struct aac_srb_reply reply; /* { dg-message "region created on stack here" "memspace message" } */ + /* { dg-message "capacity: 52 bytes" "capacity message" { target *-*-* } .-1 } */ + + reply.status = ST_OK; + + /* [...snip...] */ + + reply.srb_status = SRB_STATUS_SUCCESS; + reply.scsi_status = 0; + reply.data_xfer_length = byte_count; + reply.sense_data_size = 0; + memset(reply.sense_data, 0, AAC_SENSE_BUFFERSIZE); + + /* [...snip...] */ + + if (copy_to_user(user_reply, &reply, /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" } */ + /* { dg-message "2 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + sizeof(struct aac_srb_reply))) { + /* [...snip...] */ + } + /* [...snip...] */ +} + +static int aac_send_raw_srb_fixed(/* [...snip...] */ + void __user *user_reply) +{ + u32 byte_count = 0; + + /* [...snip...] */ + + struct aac_srb_reply reply; + + /* This is the fix. */ + memset(&reply, 0, sizeof(reply)); + + reply.status = ST_OK; + + /* [...snip...] */ + + reply.srb_status = SRB_STATUS_SUCCESS; + reply.scsi_status = 0; + reply.data_xfer_length = byte_count; + reply.sense_data_size = 0; + memset(reply.sense_data, 0, AAC_SENSE_BUFFERSIZE); + + /* [...snip...] */ + + if (copy_to_user(user_reply, &reply, /* { dg-bogus "" } */ + sizeof(struct aac_srb_reply))) { + /* [...snip...] */ + } + /* [...snip...] */ +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2017-18550-1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2017-18550-1.c new file mode 100644 index 0000000..4272da9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-CVE-2017-18550-1.c @@ -0,0 +1,175 @@ +/* "An issue was discovered in drivers/scsi/aacraid/commctrl.c in the + Linux kernel before 4.13. There is potential exposure of kernel stack + memory because aac_get_hba_info does not initialize the hbainfo structure." + + Fixed e.g. by 342ffc26693b528648bdc9377e51e4f2450b4860 on linux-4.13.y + in linux-stable. + + This is a simplified version of that code (before and after the fix). */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include <string.h> + +typedef unsigned int __u32; +typedef unsigned int u32; +typedef unsigned char u8; + +#include "test-uaccess.h" + +/* Adapted from include/uapi/linux/types.h */ + +#define __bitwise +typedef __u32 __bitwise __le32; + +/* Adapted from drivers/scsi/aacraid/aacraid.h */ + +struct aac_hba_info { + + u8 driver_name[50]; /* { dg-message "field 'driver_name' is uninitialized \\(50 bytes\\)" } */ + u8 adapter_number; + u8 system_io_bus_number; + u8 device_number; /* { dg-message "padding after field 'device_number' is uninitialized \\(3 bytes\\)" } */ + u32 function_number; + u32 vendor_id; + u32 device_id; + u32 sub_vendor_id; + u32 sub_system_id; + u32 mapped_base_address_size; /* { dg-message "field 'mapped_base_address_size' is uninitialized \\(4 bytes\\)" } */ + u32 base_physical_address_high_part; + u32 base_physical_address_low_part; + + u32 max_command_size; + u32 max_fib_size; + u32 max_scatter_gather_from_os; + u32 max_scatter_gather_to_fw; + u32 max_outstanding_fibs; + + u32 queue_start_threshold; + u32 queue_dump_threshold; + u32 max_io_size_queued; + u32 outstanding_io; + + u32 firmware_build_number; + u32 bios_build_number; + u32 driver_build_number; + u32 serial_number_high_part; + u32 serial_number_low_part; + u32 supported_options; + u32 feature_bits; + u32 currentnumber_ports; + + u8 new_comm_interface:1; /* { dg-message "field 'new_comm_interface' is uninitialized \\(1 bit\\)" } */ + u8 new_commands_supported:1; + u8 disable_passthrough:1; + u8 expose_non_dasd:1; + u8 queue_allowed:1; + u8 bled_check_enabled:1; + u8 reserved1:1; + u8 reserted2:1; + + u32 reserved3[10]; /* { dg-message "field 'reserved3' is uninitialized \\(40 bytes\\)" } */ + +}; + +struct aac_dev +{ + /* [...snip...] */ + int id; + /* [...snip...] */ + struct pci_dev *pdev; /* Our PCI interface */ + /* [...snip...] */ +}; + +/* Adapted from include/linux/pci.h */ + +struct pci_dev { + /* [...snip...] */ + struct pci_bus *bus; /* bus this device is on */ + /* [...snip...] */ + unsigned int devfn; /* encoded device & function index */ + unsigned short vendor; + unsigned short device; + unsigned short subsystem_vendor; + unsigned short subsystem_device; + /* [...snip...] */ +}; + +struct pci_bus { + /* [...snip...] */ + unsigned char number; /* bus number */ + /* [...snip...] */ +}; + +/* Adapted from drivers/scsi/aacraid/commctrl.c */ + +static int aac_get_hba_info(struct aac_dev *dev, void __user *arg) +{ + struct aac_hba_info hbainfo; /* { dg-message "region created on stack here" "memspace message" } */ + /* { dg-message "capacity: 200 bytes" "capacity message" { target *-*-* } .-1 } */ + + hbainfo.adapter_number = (u8) dev->id; + hbainfo.system_io_bus_number = dev->pdev->bus->number; + hbainfo.device_number = (dev->pdev->devfn >> 3); + hbainfo.function_number = (dev->pdev->devfn & 0x0007); + + hbainfo.vendor_id = dev->pdev->vendor; + hbainfo.device_id = dev->pdev->device; + hbainfo.sub_vendor_id = dev->pdev->subsystem_vendor; + hbainfo.sub_system_id = dev->pdev->subsystem_device; + + if (copy_to_user(arg, &hbainfo, sizeof(struct aac_hba_info))) { /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "177 bytes are uninitialized" "how much" { target *-*-* } .-1 } */ + /* [...snip...] */ + } + + return 0; +} + +static int aac_get_hba_info_fixed(struct aac_dev *dev, void __user *arg) +{ + struct aac_hba_info hbainfo; + + memset(&hbainfo, 0, sizeof(hbainfo)); + hbainfo.adapter_number = (u8) dev->id; + hbainfo.system_io_bus_number = dev->pdev->bus->number; + hbainfo.device_number = (dev->pdev->devfn >> 3); + hbainfo.function_number = (dev->pdev->devfn & 0x0007); + + hbainfo.vendor_id = dev->pdev->vendor; + hbainfo.device_id = dev->pdev->device; + hbainfo.sub_vendor_id = dev->pdev->subsystem_vendor; + hbainfo.sub_system_id = dev->pdev->subsystem_device; + + if (copy_to_user(arg, &hbainfo, sizeof(struct aac_hba_info))) { /* { dg-bogus "" } */ + /* [...snip...] */ + } + + return 0; +} + +/* An alternate fix using "= {0}" rather than memset. */ + +static int aac_get_hba_info_fixed_alt(struct aac_dev *dev, void __user *arg) +{ + struct aac_hba_info hbainfo = {0}; + + memset(&hbainfo, 0, sizeof(hbainfo)); + hbainfo.adapter_number = (u8) dev->id; + hbainfo.system_io_bus_number = dev->pdev->bus->number; + hbainfo.device_number = (dev->pdev->devfn >> 3); + hbainfo.function_number = (dev->pdev->devfn & 0x0007); + + hbainfo.vendor_id = dev->pdev->vendor; + hbainfo.device_id = dev->pdev->device; + hbainfo.sub_vendor_id = dev->pdev->subsystem_vendor; + hbainfo.sub_system_id = dev->pdev->subsystem_device; + + if (copy_to_user(arg, &hbainfo, sizeof(struct aac_hba_info))) { /* { dg-bogus "" } */ + /* [...snip...] */ + } + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-antipatterns-1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-antipatterns-1.c new file mode 100644 index 0000000..5008453 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-antipatterns-1.c @@ -0,0 +1,166 @@ +/* Adapted and simplified decls from linux kernel headers. */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +typedef unsigned char u8; +typedef unsigned __INT16_TYPE__ u16; +typedef unsigned __INT32_TYPE__ u32; +typedef __SIZE_TYPE__ size_t; + +#define EFAULT 14 + +#include "test-uaccess.h" + +typedef unsigned int gfp_t; +#define GFP_KERNEL 0 + +void kfree(const void *); +void *kmalloc(size_t size, gfp_t flags) + __attribute__((malloc (kfree))); + +/* Adapted from antipatterns.ko:infoleak.c (GPL-v2.0). */ + +struct infoleak_buf +{ + char buf[256]; +}; + +int infoleak_stack_no_init(void __user *dst) +{ + struct infoleak_buf st; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 256 bytes" "capacity" { target *-*-* } .-1 } */ + + /* No initialization of "st" at all. */ + if (copy_to_user(dst, &st, sizeof(st))) /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "256 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + return -EFAULT; + return 0; +} + +int infoleak_heap_no_init(void __user *dst) +{ + struct infoleak_buf *heapbuf = kmalloc(sizeof(*heapbuf), GFP_KERNEL); + /* No initialization of "heapbuf" at all. */ + + /* TODO: we also don't check that heapbuf could be NULL when copying + from it. */ + if (copy_to_user(dst, heapbuf, sizeof(*heapbuf))) /* { dg-warning "exposure" "warning" { xfail *-*-* } } */ + /* TODO(xfail). */ + return -EFAULT; /* { dg-warning "leak of 'heapbuf'" } */ + + kfree(heapbuf); + return 0; +} + +struct infoleak_2 +{ + u32 a; + u32 b; /* { dg-message "field 'b' is uninitialized \\(4 bytes\\)" } */ +}; + +int infoleak_stack_missing_a_field(void __user *dst, u32 v) +{ + struct infoleak_2 st; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 8 bytes" "capacity" { target *-*-* } .-1 } */ + + st.a = v; + /* No initialization of "st.b". */ + if (copy_to_user(dst, &st, sizeof(st))) /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "4 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + return -EFAULT; + return 0; +} + +int infoleak_heap_missing_a_field(void __user *dst, u32 v) +{ + struct infoleak_2 *heapbuf = kmalloc(sizeof(*heapbuf), GFP_KERNEL); + heapbuf->a = v; /* { dg-warning "dereference of possibly-NULL 'heapbuf'" } */ + /* No initialization of "heapbuf->b". */ + if (copy_to_user(dst, heapbuf, sizeof(*heapbuf))) /* { dg-warning "exposure" "warning" { xfail *-*-* } } */ + /* TODO(xfail). */ + { + kfree(heapbuf); + return -EFAULT; + } + kfree(heapbuf); + return 0; +} + +struct infoleak_3 +{ + u8 a; /* { dg-message "padding after field 'a' is uninitialized \\(3 bytes\\)" } */ + /* padding here */ + u32 b; +}; + +int infoleak_stack_padding(void __user *dst, u8 p, u32 q) +{ + struct infoleak_3 st; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 8 bytes" "capacity" { target *-*-* } .-1 } */ + + st.a = p; + st.b = q; + /* No initialization of padding. */ + if (copy_to_user(dst, &st, sizeof(st))) /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "3 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + return -EFAULT; + return 0; +} + +int infoleak_stack_unchecked_err(void __user *dst, void __user *src) +{ + struct infoleak_buf st; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 256 bytes" "capacity" { target *-*-* } .-1 } */ + + /* + * If the copy_from_user call fails, then st is still uninitialized, + * and if the copy_to_user call succeds, we have an infoleak. + */ + int err = copy_from_user (&st, src, sizeof(st)); /* { dg-message "when 'copy_from_user' fails" } */ + err |= copy_to_user (dst, &st, sizeof(st)); /* { dg-warning "exposure" "warning" } */ + /* { dg-message "256 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + /* Actually, it's *up to* 256 bytes. */ + + if (err) + return -EFAULT; + return 0; +} + +struct infoleak_4 +{ + union { + u8 f1; + u32 f2; + } u; +}; + +int infoleak_stack_union(void __user *dst, u8 v) +{ + struct infoleak_4 st; + /* + * This write only initializes the u8 within the union "u", + * leaving the remaining 3 bytes uninitialized. + */ + st.u.f1 = v; + if (copy_to_user(dst, &st, sizeof(st))) /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "3 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ + return -EFAULT; + return 0; +} + +struct infoleak_5 +{ + void *ptr; +}; + +int infoleak_stack_kernel_ptr(void __user *dst, void *kp) +{ + struct infoleak_5 st; + /* This writes a kernel-space pointer into a user space buffer. */ + st.ptr = kp; + if (copy_to_user(dst, &st, sizeof(st))) // TODO: we don't complain about this yet + return -EFAULT; + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-fixit-1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-fixit-1.c new file mode 100644 index 0000000..6961b44 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-fixit-1.c @@ -0,0 +1,26 @@ +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include <string.h> + +#include "test-uaccess.h" + +typedef unsigned char u8; +typedef unsigned int u32; + +struct st +{ + u8 i; /* { dg-message "padding after field 'i' is uninitialized \\(3 bytes\\)" } */ + u32 j; /* { dg-message "field 'j' is uninitialized \\(4 bytes\\)" } */ +}; + +void test (void __user *dst, u8 a) +{ + struct st s; /* { dg-message "region created on stack here" "where" } */ + /* { dg-message "capacity: 8 bytes" "capacity" { target *-*-* } .-1 } */ + /* { dg-message "suggest forcing zero-initialization by providing a '.0.' initializer" "fix-it hint" { target *-*-* } .-2 } */ + s.i = a; + copy_to_user(dst, &s, sizeof (struct st)); /* { dg-warning "potential exposure of sensitive information by copying uninitialized data from stack" "warning" } */ + /* { dg-message "7 bytes are uninitialized" "note how much" { target *-*-* } .-1 } */ +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-net-ethtool-ioctl.c b/gcc/testsuite/gcc.dg/plugin/infoleak-net-ethtool-ioctl.c new file mode 100644 index 0000000..dce6e44 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-net-ethtool-ioctl.c @@ -0,0 +1,82 @@ +/* Reduced from infoleak false positive seen on Linux kernel with + net/ethtool/ioctl.c */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +typedef signed char __s8; +typedef unsigned char __u8; +typedef unsigned int __u32; +typedef __s8 s8; +typedef __u32 u32; +enum { false = 0, true = 1 }; +typedef unsigned long __kernel_ulong_t; +typedef __kernel_ulong_t __kernel_size_t; +typedef _Bool bool; +typedef __kernel_size_t size_t; + +void *memset(void *s, int c, size_t n); + +extern bool +check_copy_size(const void *addr, size_t bytes, bool is_source); +extern unsigned long +_copy_from_user(void *, const void *, unsigned long); +extern unsigned long +_copy_to_user(void *, const void *, unsigned long); + +static inline +__attribute__((__always_inline__)) unsigned long +copy_from_user(void *to, const void *from, unsigned long n) { + if (__builtin_expect(!!(check_copy_size(to, n, false)), 1)) + n = _copy_from_user(to, from, n); + return n; +} +static inline +__attribute__((__always_inline__)) unsigned long +copy_to_user(void *to, const void *from, unsigned long n) { + if (__builtin_expect(!!(check_copy_size(from, n, true)), 1)) + n = _copy_to_user(to, from, n); + return n; +} +enum ethtool_link_mode_bit_indices { + __ETHTOOL_LINK_MODE_MASK_NBITS = 92 +}; +struct ethtool_link_settings { + __u32 cmd; + /* [...snip...] */ + __s8 link_mode_masks_nwords; + /* [...snip...] */ +}; + +struct ethtool_link_ksettings { + struct ethtool_link_settings base; + u32 lanes; +}; + +int ethtool_get_link_ksettings(void *useraddr) { + int err = 0; + struct ethtool_link_ksettings link_ksettings; + + if (copy_from_user(&link_ksettings.base, useraddr, + sizeof(link_ksettings.base))) + return -14; + + if ((((__ETHTOOL_LINK_MODE_MASK_NBITS) + (32) - 1) / (32)) != + link_ksettings.base.link_mode_masks_nwords) { + + memset(&link_ksettings, 0, sizeof(link_ksettings)); + link_ksettings.base.cmd = 0x0000004c; + + link_ksettings.base.link_mode_masks_nwords = + -((s8)(((__ETHTOOL_LINK_MODE_MASK_NBITS) + (32) - 1) / (32))); + + if (copy_to_user(useraddr, &link_ksettings.base, + sizeof(link_ksettings.base))) + return -14; + + return 0; + } + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/infoleak-vfio_iommu_type1.c b/gcc/testsuite/gcc.dg/plugin/infoleak-vfio_iommu_type1.c new file mode 100644 index 0000000..51ad5db --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/infoleak-vfio_iommu_type1.c @@ -0,0 +1,44 @@ +/* Reduced from infoleak false positive in drivers/vfio/vfio_iommu_type1.c */ + +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +typedef unsigned int u32; +typedef unsigned long long u64; + +unsigned long +copy_from_user(void *to, const void *from, unsigned long n); + +unsigned long +copy_to_user(void *to, const void *from, unsigned long n); + +struct vfio_iommu_type1_info { + u32 argsz; + u32 flags; + u64 iova_pgsizes; + u32 cap_offset; + /* bytes 20-23 are padding. */ +}; + +int vfio_iommu_type1_get_info(unsigned long arg) +{ + struct vfio_iommu_type1_info info; + unsigned long minsz = 16; + + if (copy_from_user(&info, (void *)arg, 16)) + return -14; + + if (info.argsz < 16) + return -22; + + if (info.argsz >= 20) { + minsz = 20; + info.cap_offset = 0; + } + + /* The padding bytes (20-23) are uninitialized, but can't be written + back, since minsz is either 16 or 20. */ + return copy_to_user((void *)arg, &info, minsz) ? -14 : 0; /* { dg-bogus "exposure" "" { xfail *-*-* } } */ + // TODO: false +ve due to not handling minsz being either 16 or 20 +} diff --git a/gcc/testsuite/gcc.dg/plugin/known-fns-1.c b/gcc/testsuite/gcc.dg/plugin/known-fns-1.c new file mode 100644 index 0000000..5fa49f6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/known-fns-1.c @@ -0,0 +1,61 @@ +/* { dg-do compile } */ +/* { dg-options "-fanalyzer" } */ +/* { dg-require-effective-target analyzer } */ + +#include "../analyzer/analyzer-decls.h" + +/* Basic example of known fn behavior. */ + +extern int returns_42 (void); + +void test_1 (void) +{ + int val = returns_42 (); + __analyzer_eval (val == 42); /* { dg-warning "TRUE" } */ +} + +/* Example of bifurcation, with a copy that can fail. */ + +extern int +attempt_to_copy (void *to, const void *from, int sz); + +void test_copy_success (void *to, const void *from, int sz) +{ + if (!attempt_to_copy (to, from, sz)) + { + /* Success */ + } +} + +void test_copy_failure (void *to, const void *from, int sz) +{ + if (attempt_to_copy (to, from, sz)) /* { dg-message "when 'attempt_to_copy' fails" } */ + __analyzer_dump_path (); /* { dg-message "path" } */ +} + +struct coord +{ + int x; + int y; + int z; +}; + +void test_copy_2 (void) +{ + struct coord to = {1, 2, 3}; + struct coord from = {4, 5, 6}; + if (attempt_to_copy (&to, &from, sizeof (struct coord))) + { + /* Failure. */ + __analyzer_eval (to.x == 1); /* { dg-warning "TRUE" } */ + __analyzer_eval (to.y == 2); /* { dg-warning "TRUE" } */ + __analyzer_eval (to.z == 3); /* { dg-warning "TRUE" } */ + } + else + { + /* Success. */ + __analyzer_eval (to.x == 4); /* { dg-warning "TRUE" } */ + __analyzer_eval (to.y == 5); /* { dg-warning "TRUE" } */ + __analyzer_eval (to.z == 6); /* { dg-warning "TRUE" } */ + } +} diff --git a/gcc/testsuite/gcc.dg/plugin/plugin.exp b/gcc/testsuite/gcc.dg/plugin/plugin.exp index 63b117d..5b7efa4 100644 --- a/gcc/testsuite/gcc.dg/plugin/plugin.exp +++ b/gcc/testsuite/gcc.dg/plugin/plugin.exp @@ -123,6 +123,32 @@ set plugin_test_list [list \ dump-2.c } \ { analyzer_gil_plugin.c \ gil-1.c } \ + { analyzer_known_fns_plugin.c \ + known-fns-1.c } \ + { analyzer_kernel_plugin.c \ + copy_from_user-1.c \ + infoleak-1.c \ + infoleak-2.c \ + infoleak-3.c \ + infoleak-CVE-2011-1078-1.c \ + infoleak-CVE-2011-1078-2.c \ + infoleak-CVE-2017-18549-1.c \ + infoleak-CVE-2017-18550-1.c \ + infoleak-antipatterns-1.c \ + infoleak-fixit-1.c \ + infoleak-net-ethtool-ioctl.c \ + infoleak-vfio_iommu_type1.c \ + taint-CVE-2011-0521-1-fixed.c \ + taint-CVE-2011-0521-1.c \ + taint-CVE-2011-0521-2-fixed.c \ + taint-CVE-2011-0521-2.c \ + taint-CVE-2011-0521-3-fixed.c \ + taint-CVE-2011-0521-3.c \ + taint-CVE-2011-0521-4.c \ + taint-CVE-2011-0521-5.c \ + taint-CVE-2011-0521-5-fixed.c \ + taint-CVE-2011-0521-6.c \ + taint-antipatterns-1.c } \ ] foreach plugin_test $plugin_test_list { diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-1-fixed.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-1-fixed.c new file mode 100644 index 0000000..0ca8137 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-1-fixed.c @@ -0,0 +1,115 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from drivers/media/dvb/ttpci/av7110_ca.c */ + +int dvb_ca_ioctl(struct file *file, unsigned int cmd, void *parg) +{ + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + unsigned long arg = (unsigned long) parg; + + /* case CA_GET_SLOT_INFO: */ + { + ca_slot_info_t *info=(ca_slot_info_t *)parg; + + if (info->num < 0 || info->num > 1) + return -EINVAL; + av7110->ci_slot[info->num].num = info->num; /* { dg-bogus "attacker-controlled value" } */ + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); + } + return 0; +} + +static struct dvb_device dvbdev_ca = { + .priv = NULL, + /* [...snip...] */ + .kernel_ioctl = dvb_ca_ioctl, +}; + +/* Adapted from drivers/media/dvb/dvb-core/dvbdev.c */ + +static DEFINE_MUTEX(dvbdev_mutex); + +int dvb_usercopy(struct file *file, + unsigned int cmd, unsigned long arg, + int (*func)(struct file *file, + unsigned int cmd, void *arg)) +{ + char sbuf[128]; + void *mbuf = NULL; + void *parg = NULL; + int err = -1; + + /* Copy arguments into temp kernel buffer */ + switch (_IOC_DIR(cmd)) { + case _IOC_NONE: + /* + * For this command, the pointer is actually an integer + * argument. + */ + parg = (void *) arg; + break; + case _IOC_READ: /* some v4l ioctls are marked wrong ... */ + case _IOC_WRITE: + case (_IOC_WRITE | _IOC_READ): + if (_IOC_SIZE(cmd) <= sizeof(sbuf)) { + parg = sbuf; + } else { + /* too big to allocate from stack */ + mbuf = kmalloc(_IOC_SIZE(cmd),GFP_KERNEL); + if (NULL == mbuf) + return -ENOMEM; + parg = mbuf; + } + + err = -EFAULT; + if (copy_from_user(parg, (void __user *)arg, _IOC_SIZE(cmd))) + goto out; + break; + } + + /* call driver */ + mutex_lock(&dvbdev_mutex); + if ((err = func(file, cmd, parg)) == -ENOIOCTLCMD) + err = -EINVAL; + mutex_unlock(&dvbdev_mutex); + + if (err < 0) + goto out; + + /* Copy results into user buffer */ + switch (_IOC_DIR(cmd)) + { + case _IOC_READ: + case (_IOC_WRITE | _IOC_READ): + if (copy_to_user((void __user *)arg, parg, _IOC_SIZE(cmd))) + err = -EFAULT; + break; + } + +out: + kfree(mbuf); + return err; +} + +long dvb_generic_ioctl(struct file *file, + unsigned int cmd, unsigned long arg) +{ + struct dvb_device *dvbdev = file->private_data; + + if (!dvbdev) + return -ENODEV; + + if (!dvbdev->kernel_ioctl) + return -EINVAL; + + return dvb_usercopy(file, cmd, arg, dvbdev->kernel_ioctl); +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-1.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-1.c new file mode 100644 index 0000000..cde12b3 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-1.c @@ -0,0 +1,115 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from drivers/media/dvb/ttpci/av7110_ca.c */ + +int dvb_ca_ioctl(struct file *file, unsigned int cmd, void *parg) +{ + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + unsigned long arg = (unsigned long) parg; + + /* case CA_GET_SLOT_INFO: */ + { + ca_slot_info_t *info=(ca_slot_info_t *)parg; + + if (info->num > 1) + return -EINVAL; + av7110->ci_slot[info->num].num = info->num; /* { dg-warning "attacker-controlled value" "" { xfail *-*-* } } */ + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); + } + return 0; +} + +static struct dvb_device dvbdev_ca = { + .priv = NULL, + /* [...snip...] */ + .kernel_ioctl = dvb_ca_ioctl, +}; + +/* Adapted from drivers/media/dvb/dvb-core/dvbdev.c */ + +static DEFINE_MUTEX(dvbdev_mutex); + +int dvb_usercopy(struct file *file, + unsigned int cmd, unsigned long arg, + int (*func)(struct file *file, + unsigned int cmd, void *arg)) +{ + char sbuf[128]; + void *mbuf = NULL; + void *parg = NULL; + int err = -1; + + /* Copy arguments into temp kernel buffer */ + switch (_IOC_DIR(cmd)) { + case _IOC_NONE: + /* + * For this command, the pointer is actually an integer + * argument. + */ + parg = (void *) arg; + break; + case _IOC_READ: /* some v4l ioctls are marked wrong ... */ + case _IOC_WRITE: + case (_IOC_WRITE | _IOC_READ): + if (_IOC_SIZE(cmd) <= sizeof(sbuf)) { + parg = sbuf; + } else { + /* too big to allocate from stack */ + mbuf = kmalloc(_IOC_SIZE(cmd),GFP_KERNEL); + if (NULL == mbuf) + return -ENOMEM; + parg = mbuf; + } + + err = -EFAULT; + if (copy_from_user(parg, (void __user *)arg, _IOC_SIZE(cmd))) + goto out; + break; + } + + /* call driver */ + mutex_lock(&dvbdev_mutex); + if ((err = func(file, cmd, parg)) == -ENOIOCTLCMD) + err = -EINVAL; + mutex_unlock(&dvbdev_mutex); + + if (err < 0) + goto out; + + /* Copy results into user buffer */ + switch (_IOC_DIR(cmd)) + { + case _IOC_READ: + case (_IOC_WRITE | _IOC_READ): + if (copy_to_user((void __user *)arg, parg, _IOC_SIZE(cmd))) + err = -EFAULT; + break; + } + +out: + kfree(mbuf); + return err; +} + +long dvb_generic_ioctl(struct file *file, + unsigned int cmd, unsigned long arg) +{ + struct dvb_device *dvbdev = file->private_data; + + if (!dvbdev) + return -ENODEV; + + if (!dvbdev->kernel_ioctl) + return -EINVAL; + + return dvb_usercopy(file, cmd, arg, dvbdev->kernel_ioctl); +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-2-fixed.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-2-fixed.c new file mode 100644 index 0000000..8a211ce --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-2-fixed.c @@ -0,0 +1,98 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +// TODO: remove need for this option +/* { dg-additional-options "-fanalyzer-checker=taint" } */ + +/* Adapted from drivers/media/dvb/ttpci/av7110_ca.c */ + +int dvb_ca_ioctl(struct file *file, unsigned int cmd, void *parg) +{ + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + unsigned long arg = (unsigned long) parg; + + /* case CA_GET_SLOT_INFO: */ + { + ca_slot_info_t *info=(ca_slot_info_t *)parg; + + if (info->num < 0 || info->num > 1) + return -EINVAL; + av7110->ci_slot[info->num].num = info->num; /* { dg-bogus "attacker-controlled value" } */ + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); + } + return 0; +} + +/* Adapted from drivers/media/dvb/dvb-core/dvbdev.c + Somewhat simplified: rather than pass in a callback that can + be dvb_ca_ioctl, call dvb_ca_ioctl directly. */ + +static DEFINE_MUTEX(dvbdev_mutex); + +int dvb_usercopy(struct file *file, + unsigned int cmd, unsigned long arg) +{ + char sbuf[128]; + void *mbuf = NULL; + void *parg = NULL; + int err = -1; + + /* Copy arguments into temp kernel buffer */ + switch (_IOC_DIR(cmd)) { + case _IOC_NONE: + /* + * For this command, the pointer is actually an integer + * argument. + */ + parg = (void *) arg; + break; + case _IOC_READ: /* some v4l ioctls are marked wrong ... */ + case _IOC_WRITE: + case (_IOC_WRITE | _IOC_READ): + if (_IOC_SIZE(cmd) <= sizeof(sbuf)) { + parg = sbuf; + } else { + /* too big to allocate from stack */ + mbuf = kmalloc(_IOC_SIZE(cmd),GFP_KERNEL); + if (NULL == mbuf) + return -ENOMEM; + parg = mbuf; + } + + err = -EFAULT; + if (copy_from_user(parg, (void __user *)arg, _IOC_SIZE(cmd))) + goto out; + break; + } + + /* call driver */ + mutex_lock(&dvbdev_mutex); + if ((err = dvb_ca_ioctl(file, cmd, parg)) == -ENOIOCTLCMD) + err = -EINVAL; + mutex_unlock(&dvbdev_mutex); + + if (err < 0) + goto out; + + /* Copy results into user buffer */ + switch (_IOC_DIR(cmd)) + { + case _IOC_READ: + case (_IOC_WRITE | _IOC_READ): + if (copy_to_user((void __user *)arg, parg, _IOC_SIZE(cmd))) + err = -EFAULT; + break; + } + +out: + kfree(mbuf); + return err; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-2.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-2.c new file mode 100644 index 0000000..30cab38 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-2.c @@ -0,0 +1,95 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from drivers/media/dvb/ttpci/av7110_ca.c */ + +int dvb_ca_ioctl(struct file *file, unsigned int cmd, void *parg) +{ + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + unsigned long arg = (unsigned long) parg; + + /* case CA_GET_SLOT_INFO: */ + { + ca_slot_info_t *info=(ca_slot_info_t *)parg; + + if (info->num > 1) + return -EINVAL; + av7110->ci_slot[info->num].num = info->num; /* { dg-warning "attacker-controlled value" "" { xfail *-*-* } } */ + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); + } + return 0; +} + +/* Adapted from drivers/media/dvb/dvb-core/dvbdev.c + Somewhat simplified: rather than pass in a callback that can + be dvb_ca_ioctl, call dvb_ca_ioctl directly. */ + +static DEFINE_MUTEX(dvbdev_mutex); + +int dvb_usercopy(struct file *file, + unsigned int cmd, unsigned long arg) +{ + char sbuf[128]; + void *mbuf = NULL; + void *parg = NULL; + int err = -1; + + /* Copy arguments into temp kernel buffer */ + switch (_IOC_DIR(cmd)) { + case _IOC_NONE: + /* + * For this command, the pointer is actually an integer + * argument. + */ + parg = (void *) arg; + break; + case _IOC_READ: /* some v4l ioctls are marked wrong ... */ + case _IOC_WRITE: + case (_IOC_WRITE | _IOC_READ): + if (_IOC_SIZE(cmd) <= sizeof(sbuf)) { + parg = sbuf; + } else { + /* too big to allocate from stack */ + mbuf = kmalloc(_IOC_SIZE(cmd),GFP_KERNEL); + if (NULL == mbuf) + return -ENOMEM; + parg = mbuf; + } + + err = -EFAULT; + if (copy_from_user(parg, (void __user *)arg, _IOC_SIZE(cmd))) + goto out; + break; + } + + /* call driver */ + mutex_lock(&dvbdev_mutex); + if ((err = dvb_ca_ioctl(file, cmd, parg)) == -ENOIOCTLCMD) + err = -EINVAL; + mutex_unlock(&dvbdev_mutex); + + if (err < 0) + goto out; + + /* Copy results into user buffer */ + switch (_IOC_DIR(cmd)) + { + case _IOC_READ: + case (_IOC_WRITE | _IOC_READ): + if (copy_to_user((void __user *)arg, parg, _IOC_SIZE(cmd))) + err = -EFAULT; + break; + } + +out: + kfree(mbuf); + return err; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-3-fixed.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-3-fixed.c new file mode 100644 index 0000000..b7852b4 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-3-fixed.c @@ -0,0 +1,61 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +// TODO: remove need for this option +/* { dg-additional-options "-fanalyzer-checker=taint" } */ + +/* Adapted from drivers/media/dvb/ttpci/av7110_ca.c */ + +int dvb_ca_ioctl(struct file *file, unsigned int cmd, void *parg) +{ + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + unsigned long arg = (unsigned long) parg; + + /* case CA_GET_SLOT_INFO: */ + { + ca_slot_info_t *info=(ca_slot_info_t *)parg; + + if (info->num < 0 || info->num > 1) + return -EINVAL; + av7110->ci_slot[info->num].num = info->num; /* { dg-bogus "attacker-controlled value" } */ + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); + } + return 0; +} + +/* Adapted from drivers/media/dvb/dvb-core/dvbdev.c + Further simplified from -2; always use an on-stack buffer. */ + +static DEFINE_MUTEX(dvbdev_mutex); + +int dvb_usercopy(struct file *file, + unsigned int cmd, unsigned long arg) +{ + char sbuf[128]; + void *parg = sbuf; + int err = -EFAULT; + if (copy_from_user(parg, (void __user *)arg, sizeof(sbuf))) + goto out; + + mutex_lock(&dvbdev_mutex); + if ((err = dvb_ca_ioctl(file, cmd, parg)) == -ENOIOCTLCMD) + err = -EINVAL; + mutex_unlock(&dvbdev_mutex); + + if (err < 0) + goto out; + + if (copy_to_user((void __user *)arg, parg, sizeof(sbuf))) + err = -EFAULT; + +out: + return err; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-3.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-3.c new file mode 100644 index 0000000..6b9e034 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-3.c @@ -0,0 +1,59 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from drivers/media/dvb/ttpci/av7110_ca.c */ + +int dvb_ca_ioctl(struct file *file, unsigned int cmd, void *parg) +{ + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + unsigned long arg = (unsigned long) parg; + + /* case CA_GET_SLOT_INFO: */ + { + ca_slot_info_t *info=(ca_slot_info_t *)parg; + + if (info->num > 1) + return -EINVAL; + av7110->ci_slot[info->num].num = info->num; /* { dg-warning "attacker-controlled value" "" { xfail *-*-* } } */ + // TODO(xfail) + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); + } + return 0; +} + +/* Adapted from drivers/media/dvb/dvb-core/dvbdev.c + Further simplified from -2; always use an on-stack buffer. */ + +static DEFINE_MUTEX(dvbdev_mutex); + +int dvb_usercopy(struct file *file, + unsigned int cmd, unsigned long arg) +{ + char sbuf[128]; + void *parg = sbuf; + int err = -EFAULT; + if (copy_from_user(parg, (void __user *)arg, sizeof(sbuf))) + goto out; + + mutex_lock(&dvbdev_mutex); + if ((err = dvb_ca_ioctl(file, cmd, parg)) == -ENOIOCTLCMD) + err = -EINVAL; + mutex_unlock(&dvbdev_mutex); + + if (err < 0) + goto out; + + if (copy_to_user((void __user *)arg, parg, sizeof(sbuf))) + err = -EFAULT; + +out: + return err; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-4.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-4.c new file mode 100644 index 0000000..f314c64 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-4.c @@ -0,0 +1,45 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +// TODO: remove need for --param=analyzer-max-svalue-depth=25 here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint --param=analyzer-max-svalue-depth=25" } */ +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from dvb_ca_ioctl in drivers/media/dvb/ttpci/av7110_ca.c and + dvb_usercopy in drivers/media/dvb/dvb-core/dvbdev.c + + Further simplified from -3; merge into a single function; drop the mutex, + remove control flow. */ + +int test_1(struct file *file, unsigned int cmd, unsigned long arg) +{ + char sbuf[128]; + void *parg = sbuf; + + if (copy_from_user(parg, (void __user *)arg, sizeof(sbuf))) + return -1; + + { + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + unsigned long arg = (unsigned long) parg; + + /* case CA_GET_SLOT_INFO: */ + ca_slot_info_t *info=(ca_slot_info_t *)parg; + + if (info->num > 1) + return -EINVAL; + av7110->ci_slot[info->num].num = info->num; /* { dg-warning "attacker-controlled value" "" { xfail *-*-* } } */ + // TODO(xfail) + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); + } + + copy_to_user((void __user *)arg, parg, sizeof(sbuf)); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-5-fixed.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-5-fixed.c new file mode 100644 index 0000000..8cb067c --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-5-fixed.c @@ -0,0 +1,46 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +// TODO: remove need for --param=analyzer-max-svalue-depth=25 here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint --param=analyzer-max-svalue-depth=25" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from dvb_ca_ioctl in drivers/media/dvb/ttpci/av7110_ca.c and + dvb_usercopy in drivers/media/dvb/dvb-core/dvbdev.c + + Further simplified from -4; avoid parg and the cast to char[128]. */ + +int test_1(struct file *file, unsigned int cmd, unsigned long arg) +{ + ca_slot_info_t sbuf; + + if (copy_from_user(&sbuf, (void __user *)arg, sizeof(sbuf)) != 0) + return -1; + + { + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + + /* case CA_GET_SLOT_INFO: */ + ca_slot_info_t *info= &sbuf; + + __analyzer_dump_state ("taint", info->num); /* { dg-warning "tainted" } */ + + if (info->num < 0 || info->num > 1) + return -EINVAL; + + __analyzer_dump_state ("taint", info->num); /* { dg-warning "stop" } */ + + av7110->ci_slot[info->num].num = info->num; + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); /* { dg-bogus "use of attacker-controlled value in array lookup without bounds checking" "" { xfail *-*-* } } */ + // FIXME: why the above false +ve? + } + + copy_to_user((void __user *)arg, &sbuf, sizeof(sbuf)); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-5.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-5.c new file mode 100644 index 0000000..4ce0479 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-5.c @@ -0,0 +1,45 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +// TODO: remove need for --param=analyzer-max-svalue-depth=25 here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint --param=analyzer-max-svalue-depth=25" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from dvb_ca_ioctl in drivers/media/dvb/ttpci/av7110_ca.c and + dvb_usercopy in drivers/media/dvb/dvb-core/dvbdev.c + + Further simplified from -4; avoid parg and the cast to char[128]. */ + +int test_1(struct file *file, unsigned int cmd, unsigned long arg) +{ + ca_slot_info_t sbuf; + + if (copy_from_user(&sbuf, (void __user *)arg, sizeof(sbuf)) != 0) + return -1; + + { + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + + /* case CA_GET_SLOT_INFO: */ + ca_slot_info_t *info= &sbuf; + + __analyzer_dump_state ("taint", info->num); /* { dg-warning "tainted" } */ + + if (info->num > 1) + return -EINVAL; + + __analyzer_dump_state ("taint", info->num); /* { dg-warning "has_ub" } */ + + av7110->ci_slot[info->num].num = info->num; /* { dg-warning "use of attacker-controlled value '\\*info\\.num' in array lookup without checking for negative" } */ + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? /* { dg-warning "use of attacker-controlled value '\\*info\\.num' in array lookup without checking for negative" } */ + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); /* { dg-warning "use of attacker-controlled value in array lookup without bounds checking" } */ + } + + copy_to_user((void __user *)arg, &sbuf, sizeof(sbuf)); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-6.c b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-6.c new file mode 100644 index 0000000..c54af79 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521-6.c @@ -0,0 +1,42 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +// TODO: remove need for --param=analyzer-max-svalue-depth=25 here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint --param=analyzer-max-svalue-depth=25" } */ +/* { dg-require-effective-target analyzer } */ + +/* See notes in this header. */ +#include "taint-CVE-2011-0521.h" + +/* Adapted from dvb_ca_ioctl in drivers/media/dvb/ttpci/av7110_ca.c and + dvb_usercopy in drivers/media/dvb/dvb-core/dvbdev.c + + Further simplified from -5; remove all control flow. */ + +int test_1(struct file *file, unsigned int cmd, unsigned long arg) +{ + ca_slot_info_t sbuf; + + if (copy_from_user(&sbuf, (void __user *)arg, sizeof(sbuf)) != 0) + return -1; + + { + struct dvb_device *dvbdev = file->private_data; + struct av7110 *av7110 = dvbdev->priv; + + /* case CA_GET_SLOT_INFO: */ + ca_slot_info_t *info= &sbuf; + + __analyzer_dump_state ("taint", info->num); /* { dg-warning "tainted" } */ + + //__analyzer_break (); + + av7110->ci_slot[info->num].num = info->num; /* { dg-warning "use of attacker-controlled value '\\*info\\.num' in array lookup without bounds checking" } */ + av7110->ci_slot[info->num].type = FW_CI_LL_SUPPORT(av7110->arm_app) ? /* { dg-warning "use of attacker-controlled value '\\*info\\.num' in array lookup without bounds checking" } */ + CA_CI_LINK : CA_CI; + memcpy(info, &av7110->ci_slot[info->num], sizeof(ca_slot_info_t)); /* { dg-warning "use of attacker-controlled value in array lookup without bounds checking" } */ + } + + copy_to_user((void __user *)arg, &sbuf, sizeof(sbuf)); + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521.h b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521.h new file mode 100644 index 0000000..29f66b6 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-CVE-2011-0521.h @@ -0,0 +1,136 @@ +/* Shared header for the various taint-CVE-2011-0521-*.c tests. + These are a series of successively simpler reductions of the reproducer. + Ideally the analyzer would detect the issue in all of the testcases, + but currently requires some simplification of the code to do so. + + "The dvb_ca_ioctl function in drivers/media/dvb/ttpci/av7110_ca.c in the + Linux kernel before 2.6.38-rc2 does not check the sign of a certain integer + field, which allows local users to cause a denial of service (memory + corruption) or possibly have unspecified other impact via a negative value." + + Adapted from Linux 2.6.38, which is under the GPLv2. + + Fixed in e.g. cb26a24ee9706473f31d34cc259f4dcf45cd0644 on linux-2.6.38.y */ + +#include <string.h> +#include "test-uaccess.h" +#include "../analyzer/analyzer-decls.h" + +typedef unsigned int u32; + +/* Adapted from include/linux/compiler.h */ + +#define __force + +/* Adapted from include/asm-generic/errno-base.h */ + +#define ENOMEM 12 /* Out of memory */ +#define EFAULT 14 /* Bad address */ +#define ENODEV 19 /* No such device */ +#define EINVAL 22 /* Invalid argument */ + +/* Adapted from include/linux/errno.h */ + +#define ENOIOCTLCMD 515 /* No ioctl command */ + +/* Adapted from include/linux/fs.h */ + +struct file { + /* [...snip...] */ + void *private_data; + /* [...snip...] */ +}; + +/* Adapted from drivers/media/dvb/dvb-core/dvbdev.h */ + +struct dvb_device { + /* [...snip...] */ + int (*kernel_ioctl)(struct file *file, unsigned int cmd, void *arg); + + void *priv; +}; + + +/* Adapted from include/linux/dvb/ca.h */ + +typedef struct ca_slot_info { + int num; /* slot number */ + + int type; /* CA interface this slot supports */ +#define CA_CI 1 /* CI high level interface */ +#define CA_CI_LINK 2 /* CI link layer level interface */ + /* [...snip...] */ +} ca_slot_info_t; + + +/* Adapted from drivers/media/dvb/ttpci/av7110.h */ + +struct av7110 { + /* [...snip...] */ + ca_slot_info_t ci_slot[2]; + /* [...snip...] */ + u32 arm_app; + /* [...snip...] */ +}; + +/* Adapted from drivers/media/dvb/ttpci/av7110_hw.h */ + +#define FW_CI_LL_SUPPORT(arm_app) ((arm_app) & 0x80000000) + +/* Adapted from include/asm-generic/ioctl.h */ + +#define _IOC_NRBITS 8 +#define _IOC_TYPEBITS 8 + +#define _IOC_SIZEBITS 14 +#define _IOC_DIRBITS 2 + +#define _IOC_SIZEMASK ((1 << _IOC_SIZEBITS)-1) +#define _IOC_DIRMASK ((1 << _IOC_DIRBITS)-1) +#define _IOC_NRSHIFT 0 +#define _IOC_TYPESHIFT (_IOC_NRSHIFT+_IOC_NRBITS) +#define _IOC_SIZESHIFT (_IOC_TYPESHIFT+_IOC_TYPEBITS) +#define _IOC_DIRSHIFT (_IOC_SIZESHIFT+_IOC_SIZEBITS) + +#define _IOC_NONE 0U +#define _IOC_WRITE 1U +#define _IOC_READ 2U + +#define _IOC_DIR(nr) (((nr) >> _IOC_DIRSHIFT) & _IOC_DIRMASK) +#define _IOC_SIZE(nr) (((nr) >> _IOC_SIZESHIFT) & _IOC_SIZEMASK) + +/* Adapted from include/linux/mutex.h */ + +struct mutex { + /* [...snip...] */ +}; + +#define __MUTEX_INITIALIZER(lockname) \ + { /* [...snip...] */ } + +#define DEFINE_MUTEX(mutexname) \ + struct mutex mutexname = __MUTEX_INITIALIZER(mutexname) + +extern void mutex_lock(struct mutex *lock); +extern void mutex_unlock(struct mutex *lock); + +/* Adapted from include/linux/types.h */ + +#define __bitwise__ +typedef unsigned __bitwise__ gfp_t; + +/* Adapted from include/linux/gfp.h */ + +#define ___GFP_WAIT 0x10u +#define ___GFP_IO 0x40u +#define ___GFP_FS 0x80u +#define __GFP_WAIT ((__force gfp_t)___GFP_WAIT) +#define __GFP_IO ((__force gfp_t)___GFP_IO) +#define __GFP_FS ((__force gfp_t)___GFP_FS) +#define GFP_KERNEL (__GFP_WAIT | __GFP_IO | __GFP_FS) + +/* Adapted from include/linux/slab.h */ + +void kfree(const void *); +void *kmalloc(size_t size, gfp_t flags) + __attribute__((malloc (kfree))); diff --git a/gcc/testsuite/gcc.dg/plugin/taint-antipatterns-1.c b/gcc/testsuite/gcc.dg/plugin/taint-antipatterns-1.c new file mode 100644 index 0000000..6bb6f1b --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/taint-antipatterns-1.c @@ -0,0 +1,139 @@ +/* { dg-do compile } */ +// TODO: remove need for -fanalyzer-checker=taint here: +/* { dg-options "-fanalyzer -fanalyzer-checker=taint" } */ +/* { dg-require-effective-target analyzer } */ + +#include "test-uaccess.h" + +/* Adapted and simplified decls from linux kernel headers. */ + +typedef unsigned char u8; +typedef unsigned __INT16_TYPE__ u16; +typedef unsigned __INT32_TYPE__ u32; +typedef signed __INT32_TYPE__ s32; +typedef __SIZE_TYPE__ size_t; + +#define EFAULT 14 + +typedef unsigned int gfp_t; +#define GFP_KERNEL 0 + +void kfree(const void *); +void *kmalloc(size_t size, gfp_t flags) + __attribute__((malloc (kfree))); + +/* Adapted from antipatterns.ko:taint.c (GPL-v2.0). */ + +struct cmd_1 +{ + u32 idx; + u32 val; +}; + +static u32 arr[16]; + +int taint_array_access(void __user *src) +{ + struct cmd_1 cmd; + if (copy_from_user(&cmd, src, sizeof(cmd))) + return -EFAULT; + /* + * cmd.idx is an unsanitized value from user-space, hence + * this is an arbitrary kernel memory access. + */ + arr[cmd.idx] = cmd.val; /* { dg-warning "use of attacker-controlled value 'cmd.idx' in array lookup without upper-bounds checking" } */ + return 0; +} + +struct cmd_2 +{ + s32 idx; + u32 val; +}; + +int taint_signed_array_access(void __user *src) +{ + struct cmd_2 cmd; + if (copy_from_user(&cmd, src, sizeof(cmd))) + return -EFAULT; + if (cmd.idx >= 16) + return -EFAULT; + + /* + * cmd.idx hasn't been checked for being negative, hence + * this is an arbitrary kernel memory access. + */ + arr[cmd.idx] = cmd.val; /* { dg-warning "use of attacker-controlled value 'cmd.idx' in array lookup without checking for negative" } */ + return 0; +} + +struct cmd_s32_binop +{ + s32 a; + s32 b; + s32 result; +}; + +int taint_divide_by_zero_direct(void __user *uptr) +{ + struct cmd_s32_binop cmd; + if (copy_from_user(&cmd, uptr, sizeof(cmd))) + return -EFAULT; + + /* cmd.b is attacker-controlled and could be zero */ + cmd.result = cmd.a / cmd.b; /* { dg-warning "use of attacker-controlled value 'cmd.b' as divisor without checking for zero" } */ + + if (copy_to_user (uptr, &cmd, sizeof(cmd))) + return -EFAULT; + return 0; +} + +int taint_divide_by_zero_compound(void __user *uptr) +{ + struct cmd_s32_binop cmd; + if (copy_from_user(&cmd, uptr, sizeof(cmd))) + return -EFAULT; + + /* + * cmd.b is attacker-controlled and could be -1, hence + * the divisor could be zero + */ + cmd.result = cmd.a / (cmd.b + 1); /* { dg-warning "use of attacker-controlled value 'cmd.b \\+ 1' as divisor without checking for zero" } */ + + if (copy_to_user (uptr, &cmd, sizeof(cmd))) + return -EFAULT; + return 0; +} + +int taint_mod_by_zero_direct(void __user *uptr) +{ + struct cmd_s32_binop cmd; + if (copy_from_user(&cmd, uptr, sizeof(cmd))) + return -EFAULT; + + /* cmd.b is attacker-controlled and could be zero */ + cmd.result = cmd.a % cmd.b; /* { dg-warning "use of attacker-controlled value 'cmd.b' as divisor without checking for zero" } */ + + if (copy_to_user (uptr, &cmd, sizeof(cmd))) + return -EFAULT; + return 0; +} + +int taint_mod_by_zero_compound(void __user *uptr) +{ + struct cmd_s32_binop cmd; + if (copy_from_user(&cmd, uptr, sizeof(cmd))) + return -EFAULT; + + /* + * cmd.b is attacker-controlled and could be -1, hence + * the divisor could be zero + */ + cmd.result = cmd.a % (cmd.b + 1); /* { dg-warning "use of attacker-controlled value 'cmd.b \\+ 1' as divisor without checking for zero" } */ + + if (copy_to_user (uptr, &cmd, sizeof(cmd))) + return -EFAULT; + return 0; +} + +/* TODO: etc. */ diff --git a/gcc/testsuite/gcc.dg/plugin/test-uaccess.h b/gcc/testsuite/gcc.dg/plugin/test-uaccess.h new file mode 100644 index 0000000..42eac98 --- /dev/null +++ b/gcc/testsuite/gcc.dg/plugin/test-uaccess.h @@ -0,0 +1,10 @@ +/* Shared header for testcases for copy_from_user/copy_to_user. */ + +/* Adapted from include/linux/compiler.h */ + +#define __user + +/* Adapted from include/asm-generic/uaccess.h */ + +extern long copy_from_user(void *to, const void __user *from, long n); +extern long copy_to_user(void __user *to, const void *from, long n); diff --git a/gcc/testsuite/gcc.dg/pr106844.c b/gcc/testsuite/gcc.dg/pr106844.c new file mode 100644 index 0000000..df68d76 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr106844.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-O -Wuninitialized --param uninit-control-dep-attempts=1" } */ + +struct { + int count; + int array[8]; +} fde_merge_v1; + +void +fde_merge_i2() { + unsigned i1; + do + while (i1 && fde_merge_v1.array[i1 - 1]) /* { dg-warning "uninitialized" } */ + i1--; + while (fde_merge_i2); +} diff --git a/gcc/testsuite/gcc.dg/torture/pr106892.c b/gcc/testsuite/gcc.dg/torture/pr106892.c new file mode 100644 index 0000000..73a66a0 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr106892.c @@ -0,0 +1,30 @@ +/* { dg-do run } */ + +int a, b, c, d, e; +int f[8]; +static int g() { + while (a) + a >>= 4; + return 0; +} +static int h(int i) { + if (i >= '0') + return i - '0'; + //__builtin_unreachable (); +} +void __attribute__((noipa)) j(int i) { + for (b = 2; g() <= 7; b++) + if (i) { + for (; e <= 7; e++) + for (c = 1; c <= 7; c++) { + d = h(b + '0'); + f[-d + 4] ^= 3; + } + return; + } +} +int main() { + j(1); + if (f[2] != 0) + __builtin_abort (); +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/pr106867.c b/gcc/testsuite/gcc.dg/tree-ssa/pr106867.c new file mode 100644 index 0000000..68773d9 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/pr106867.c @@ -0,0 +1,16 @@ +// { dg-do compile } +// { dg-options "-O2 -fno-tree-fre" } + +double m; +int n; + +void +foo (void) +{ + static double a[] = { 0.0 / 0.0, 0.0 }; + int i; + + for (i = 0; i < n; ++i) + if (m >= a[i]) + __builtin_abort (); +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/vrp-float-inf-1.c b/gcc/testsuite/gcc.dg/tree-ssa/vrp-float-inf-1.c new file mode 100644 index 0000000..1d21cce4 --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/vrp-float-inf-1.c @@ -0,0 +1,15 @@ +// { dg-do compile } +// { dg-options "-O2 -fdump-tree-evrp-details" } + +void foo (); +void bar (double); + +void funky(double f, double g) +{ + if (f <= __builtin_inf ()) + foo (); + else + bar (f); +} + +// { dg-final { scan-tree-dump-not " Inf, Inf" "evrp" } } diff --git a/gcc/testsuite/gcc.dg/uninit-pr106155-1.c b/gcc/testsuite/gcc.dg/uninit-pr106155-1.c new file mode 100644 index 0000000..5c4410d --- /dev/null +++ b/gcc/testsuite/gcc.dg/uninit-pr106155-1.c @@ -0,0 +1,40 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fno-ivopts -Wuninitialized" } */ + +int *e; +int f1 (void); +void f2 (int); +long f3 (void *, long, int *); +void f4 (void *); +int *fh; + +void tst (void) +{ + int status; + unsigned char badData[3][3] = { { 7 }, { 16 }, { 23 } }; + int badDataSize[3] = { 1, 1, 1 }; + int i; + + for (i = 0; i < 3; i++) + { + int emax; + if (i == 2) + emax = f1 (); + status = f3 (&badData[i][0], badDataSize[i], fh); + if (status) + { + f1 (); + f1 (); + f1 (); + } + f4 (fh); + *e = 0; + f1 (); + /* When threading the following out of the loop uninit + analysis needs to pick up the loop exit condition + to match up with this guard. + ??? This doesn't work reliably when IVOPTs is run. */ + if (i == 2) + f2 (emax); /* { dg-bogus "uninitialized" } */ + } +} diff --git a/gcc/testsuite/gcc.dg/uninit-pr106866.c b/gcc/testsuite/gcc.dg/uninit-pr106866.c new file mode 100644 index 0000000..530e274 --- /dev/null +++ b/gcc/testsuite/gcc.dg/uninit-pr106866.c @@ -0,0 +1,38 @@ +/* { dg-do compile } */ +/* { dg-options "-O1 -fno-ipa-pure-const -Wuninitialized" } */ + +int n; + +void +empty (int) +{ +} + +int +bar (int x) +{ + return n + x + 1; +} + +__attribute__ ((pure, returns_twice)) int +foo (void) +{ + int uninitialized; + + if (n) + { + if (bar (0)) + return 0; + + __builtin_unreachable (); + } + + while (uninitialized < 1) /* { dg-warning "uninitialized" } */ + { + foo (); + empty (bar (0) == foo ()); + ++uninitialized; + } + + return 0; +} diff --git a/gcc/testsuite/gcc.dg/uninit-pr106881.c b/gcc/testsuite/gcc.dg/uninit-pr106881.c new file mode 100644 index 0000000..343b13e --- /dev/null +++ b/gcc/testsuite/gcc.dg/uninit-pr106881.c @@ -0,0 +1,16 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fexceptions -Wuninitialized" } */ + +void l_free (void *); +char *l_settings_get_string (); +void eap_append_secret (); +inline void auto_free(void *a) { + void **p = a; + l_free(*p); /* { dg-warning "uninitialized" } */ +} +void eap_gtc_check_settings() { + char *identity __attribute__((cleanup(auto_free))); + char password __attribute__((cleanup(auto_free))); + identity = l_settings_get_string(); + eap_append_secret(); +} diff --git a/gcc/testsuite/gcc.dg/uninit-pred-12.c b/gcc/testsuite/gcc.dg/uninit-pred-12.c new file mode 100644 index 0000000..4c66486 --- /dev/null +++ b/gcc/testsuite/gcc.dg/uninit-pred-12.c @@ -0,0 +1,34 @@ +/* { dg-do compile } */ +/* { dg-options "-O -Wmaybe-uninitialized -fdump-tree-uninit1" } */ + +extern unsigned bar (void); +extern void quux (void); +int z; +unsigned foo (unsigned v, int y, int w) +{ + unsigned u; + if (v != 1) + u = bar (); + + // Prevent the "dom" pass from changing the CFG layout based on the inference + // 'if (v != 1) is false then (v != 2) is true'. (Now it would have to + // duplicate the loop in order to do so, which is deemed expensive.) + for (int i = 0; i < 10; i++) + quux (); + + // This variantion from uninit-pred-11.c caused compute_control_dep_chain + // to run into a defect, producing z != 0 && v != 1, omitting !(i<10) + // from the path predicate + if (w) + { + if (y) + z = 1; + if (v != 1) + return u; /* { dg-bogus "may be used uninitialized" } */ + } + + return 0; +} + +/* Make sure predicate analysis picked up the loop exit condition. */ +/* { dg-final { scan-tree-dump "AND \\(NOT \\((ivtmp|doloop)" "uninit1" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/bb-slp-layout-21.c b/gcc/testsuite/gcc.dg/vect/bb-slp-layout-21.c new file mode 100644 index 0000000..c851d58 --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/bb-slp-layout-21.c @@ -0,0 +1,23 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-march=bdver2" { target x86_64-*-* i?86-*-* } } */ + +int rl2GeomExport64_little_endian, rl2GeomExport64_little_endian_arch; +void rl2GeomExport64(unsigned char *p, double value) { + union { + unsigned char byte[8]; + double double_value; + } convert; + convert.double_value = value; + if (rl2GeomExport64_little_endian_arch) + if (rl2GeomExport64_little_endian) { + *(p + 7) = convert.byte[0]; + *(p + 6) = convert.byte[1]; + *(p + 5) = convert.byte[2]; + *(p + 4) = convert.byte[3]; + *(p + 3) = convert.byte[4]; + *(p + 2) = convert.byte[5]; + *(p + 1) = convert.byte[6]; + *p = convert.byte[7]; + } else + *p = convert.byte[7]; +} diff --git a/gcc/testsuite/gcc.target/aarch64/movdf_1.c b/gcc/testsuite/gcc.target/aarch64/movdf_1.c new file mode 100644 index 0000000..a51ded1 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movdf_1.c @@ -0,0 +1,53 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +/* +** fpr_to_fpr: +** fmov d0, d1 +** ret +*/ +double +fpr_to_fpr (double q0, double q1) +{ + return q1; +} + +/* +** gpr_to_fpr: +** fmov d0, x0 +** ret +*/ +double +gpr_to_fpr () +{ + register double x0 asm ("x0"); + asm volatile ("" : "=r" (x0)); + return x0; +} + +/* +** zero_to_fpr: +** fmov d0, xzr +** ret +*/ +double +zero_to_fpr () +{ + return 0; +} + +/* +** fpr_to_gpr: +** fmov x0, d0 +** ret +*/ +void +fpr_to_gpr (double q0) +{ + register double x0 asm ("x0"); + x0 = q0; + asm volatile ("" :: "r" (x0)); +} diff --git a/gcc/testsuite/gcc.target/aarch64/movdi_2.c b/gcc/testsuite/gcc.target/aarch64/movdi_2.c new file mode 100644 index 0000000..dd3fc3e --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movdi_2.c @@ -0,0 +1,61 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +#include <stdint.h> + +/* +** fpr_to_fpr: +** fmov d0, d1 +** ret +*/ +void +fpr_to_fpr (void) +{ + register uint64_t q0 asm ("q0"); + register uint64_t q1 asm ("q1"); + asm volatile ("" : "=w" (q1)); + q0 = q1; + asm volatile ("" :: "w" (q0)); +} + +/* +** gpr_to_fpr: +** fmov d0, x0 +** ret +*/ +void +gpr_to_fpr (uint64_t x0) +{ + register uint64_t q0 asm ("q0"); + q0 = x0; + asm volatile ("" :: "w" (q0)); +} + +/* +** zero_to_fpr: +** fmov d0, xzr +** ret +*/ +void +zero_to_fpr () +{ + register uint64_t q0 asm ("q0"); + q0 = 0; + asm volatile ("" :: "w" (q0)); +} + +/* +** fpr_to_gpr: +** fmov x0, d0 +** ret +*/ +uint64_t +fpr_to_gpr () +{ + register uint64_t q0 asm ("q0"); + asm volatile ("" : "=w" (q0)); + return q0; +} diff --git a/gcc/testsuite/gcc.target/aarch64/movhf_1.c b/gcc/testsuite/gcc.target/aarch64/movhf_1.c new file mode 100644 index 0000000..cae25d4 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movhf_1.c @@ -0,0 +1,53 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +/* +** fpr_to_fpr: +** fmov s0, s1 +** ret +*/ +_Float16 +fpr_to_fpr (_Float16 q0, _Float16 q1) +{ + return q1; +} + +/* +** gpr_to_fpr: +** fmov s0, w0 +** ret +*/ +_Float16 +gpr_to_fpr () +{ + register _Float16 w0 asm ("w0"); + asm volatile ("" : "=r" (w0)); + return w0; +} + +/* +** zero_to_fpr: +** fmov s0, wzr +** ret +*/ +_Float16 +zero_to_fpr () +{ + return 0; +} + +/* +** fpr_to_gpr: +** fmov w0, s0 +** ret +*/ +void +fpr_to_gpr (_Float16 q0) +{ + register _Float16 w0 asm ("w0"); + w0 = q0; + asm volatile ("" :: "r" (w0)); +} diff --git a/gcc/testsuite/gcc.target/aarch64/movhi_1.c b/gcc/testsuite/gcc.target/aarch64/movhi_1.c new file mode 100644 index 0000000..8017abc --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movhi_1.c @@ -0,0 +1,61 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +#include <stdint.h> + +/* +** fpr_to_fpr: +** fmov s0, s1 +** ret +*/ +void +fpr_to_fpr (void) +{ + register uint16_t q0 asm ("q0"); + register uint16_t q1 asm ("q1"); + asm volatile ("" : "=w" (q1)); + q0 = q1; + asm volatile ("" :: "w" (q0)); +} + +/* +** gpr_to_fpr: +** fmov s0, w0 +** ret +*/ +void +gpr_to_fpr (uint16_t w0) +{ + register uint16_t q0 asm ("q0"); + q0 = w0; + asm volatile ("" :: "w" (q0)); +} + +/* +** zero_to_fpr: +** fmov s0, wzr +** ret +*/ +void +zero_to_fpr () +{ + register uint16_t q0 asm ("q0"); + q0 = 0; + asm volatile ("" :: "w" (q0)); +} + +/* +** fpr_to_gpr: +** fmov w0, s0 +** ret +*/ +uint16_t +fpr_to_gpr () +{ + register uint16_t q0 asm ("q0"); + asm volatile ("" : "=w" (q0)); + return q0; +} diff --git a/gcc/testsuite/gcc.target/aarch64/movqi_1.c b/gcc/testsuite/gcc.target/aarch64/movqi_1.c new file mode 100644 index 0000000..401a796 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movqi_1.c @@ -0,0 +1,61 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +#include <stdint.h> + +/* +** fpr_to_fpr: +** fmov s0, s1 +** ret +*/ +void +fpr_to_fpr (void) +{ + register uint8_t q0 asm ("q0"); + register uint8_t q1 asm ("q1"); + asm volatile ("" : "=w" (q1)); + q0 = q1; + asm volatile ("" :: "w" (q0)); +} + +/* +** gpr_to_fpr: +** fmov s0, w0 +** ret +*/ +void +gpr_to_fpr (uint8_t w0) +{ + register uint8_t q0 asm ("q0"); + q0 = w0; + asm volatile ("" :: "w" (q0)); +} + +/* +** zero_to_fpr: +** fmov s0, wzr +** ret +*/ +void +zero_to_fpr () +{ + register uint8_t q0 asm ("q0"); + q0 = 0; + asm volatile ("" :: "w" (q0)); +} + +/* +** fpr_to_gpr: +** fmov w0, s0 +** ret +*/ +uint8_t +fpr_to_gpr () +{ + register uint8_t q0 asm ("q0"); + asm volatile ("" : "=w" (q0)); + return q0; +} diff --git a/gcc/testsuite/gcc.target/aarch64/movsf_1.c b/gcc/testsuite/gcc.target/aarch64/movsf_1.c new file mode 100644 index 0000000..09715aa --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movsf_1.c @@ -0,0 +1,53 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +/* +** fpr_to_fpr: +** fmov s0, s1 +** ret +*/ +float +fpr_to_fpr (float q0, float q1) +{ + return q1; +} + +/* +** gpr_to_fpr: +** fmov s0, w0 +** ret +*/ +float +gpr_to_fpr () +{ + register float w0 asm ("w0"); + asm volatile ("" : "=r" (w0)); + return w0; +} + +/* +** zero_to_fpr: +** fmov s0, wzr +** ret +*/ +float +zero_to_fpr () +{ + return 0; +} + +/* +** fpr_to_gpr: +** fmov w0, s0 +** ret +*/ +void +fpr_to_gpr (float q0) +{ + register float w0 asm ("w0"); + w0 = q0; + asm volatile ("" :: "r" (w0)); +} diff --git a/gcc/testsuite/gcc.target/aarch64/movsi_1.c b/gcc/testsuite/gcc.target/aarch64/movsi_1.c new file mode 100644 index 0000000..5314139 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movsi_1.c @@ -0,0 +1,61 @@ +/* { dg-do assemble } */ +/* { dg-options "-O --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +#include <stdint.h> + +/* +** fpr_to_fpr: +** fmov s0, s1 +** ret +*/ +void +fpr_to_fpr (void) +{ + register uint32_t q0 asm ("q0"); + register uint32_t q1 asm ("q1"); + asm volatile ("" : "=w" (q1)); + q0 = q1; + asm volatile ("" :: "w" (q0)); +} + +/* +** gpr_to_fpr: +** fmov s0, w0 +** ret +*/ +void +gpr_to_fpr (uint32_t w0) +{ + register uint32_t q0 asm ("q0"); + q0 = w0; + asm volatile ("" :: "w" (q0)); +} + +/* +** zero_to_fpr: +** fmov s0, wzr +** ret +*/ +void +zero_to_fpr () +{ + register uint32_t q0 asm ("q0"); + q0 = 0; + asm volatile ("" :: "w" (q0)); +} + +/* +** fpr_to_gpr: +** fmov w0, s0 +** ret +*/ +uint32_t +fpr_to_gpr () +{ + register uint32_t q0 asm ("q0"); + asm volatile ("" : "=w" (q0)); + return q0; +} diff --git a/gcc/testsuite/gcc.target/aarch64/movtf_2.c b/gcc/testsuite/gcc.target/aarch64/movtf_2.c new file mode 100644 index 0000000..38b1635 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movtf_2.c @@ -0,0 +1,81 @@ +/* { dg-do assemble } */ +/* { dg-require-effective-target large_long_double } */ +/* { dg-options "-O -mtune=neoverse-v1 --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +/* +** fpr_to_fpr: +** sub sp, sp, #16 +** str q1, \[sp\] +** ldr q0, \[sp\] +** add sp, sp, #?16 +** ret +*/ +long double +fpr_to_fpr (long double q0, long double q1) +{ + return q1; +} + +/* +** gpr_to_fpr: { target aarch64_little_endian } +** fmov d0, x0 +** fmov v0.d\[1\], x1 +** ret +*/ +/* +** gpr_to_fpr: { target aarch64_big_endian } +** fmov d0, x1 +** fmov v0.d\[1\], x0 +** ret +*/ +long double +gpr_to_fpr () +{ + register long double x0 asm ("x0"); + asm volatile ("" : "=r" (x0)); + return x0; +} + +/* +** zero_to_fpr: +** fmov s0, wzr +** ret +*/ +long double +zero_to_fpr () +{ + return 0; +} + +/* +** fpr_to_gpr: { target aarch64_little_endian } +** ( +** fmov x0, d0 +** fmov x1, v0.d\[1\] +** | +** fmov x1, v0.d\[1\] +** fmov x0, d0 +** ) +** ret +*/ +/* +** fpr_to_gpr: { target aarch64_big_endian } +** ( +** fmov x1, d0 +** fmov x0, v0.d\[1\] +** | +** fmov x0, v0.d\[1\] +** fmov x1, d0 +** ) +** ret +*/ +void +fpr_to_gpr (long double q0) +{ + register long double x0 asm ("x0"); + x0 = q0; + asm volatile ("" :: "r" (x0)); +} diff --git a/gcc/testsuite/gcc.target/aarch64/movti_2.c b/gcc/testsuite/gcc.target/aarch64/movti_2.c new file mode 100644 index 0000000..c393b12 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movti_2.c @@ -0,0 +1,86 @@ +/* { dg-do assemble } */ +/* { dg-options "-O -mtune=neoverse-v1 --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +/* +** fpr_to_fpr: +** sub sp, sp, #16 +** str q1, \[sp\] +** ldr q0, \[sp\] +** add sp, sp, #?16 +** ret +*/ +void +fpr_to_fpr (void) +{ + register __int128_t q0 asm ("q0"); + register __int128_t q1 asm ("q1"); + asm volatile ("" : "=w" (q1)); + q0 = q1; + asm volatile ("" :: "w" (q0)); +} + +/* +** gpr_to_fpr: { target aarch64_little_endian } +** fmov d0, x0 +** fmov v0.d\[1\], x1 +** ret +*/ +/* +** gpr_to_fpr: { target aarch64_big_endian } +** fmov d0, x1 +** fmov v0.d\[1\], x0 +** ret +*/ +void +gpr_to_fpr (__int128_t x0) +{ + register __int128_t q0 asm ("q0"); + q0 = x0; + asm volatile ("" :: "w" (q0)); +} + +/* +** zero_to_fpr: +** fmov d0, xzr +** ret +*/ +void +zero_to_fpr () +{ + register __int128_t q0 asm ("q0"); + q0 = 0; + asm volatile ("" :: "w" (q0)); +} + +/* +** fpr_to_gpr: { target aarch64_little_endian } +** ( +** fmov x0, d0 +** fmov x1, v0.d\[1\] +** | +** fmov x1, v0.d\[1\] +** fmov x0, d0 +** ) +** ret +*/ +/* +** fpr_to_gpr: { target aarch64_big_endian } +** ( +** fmov x1, d0 +** fmov x0, v0.d\[1\] +** | +** fmov x0, v0.d\[1\] +** fmov x1, d0 +** ) +** ret +*/ +__int128_t +fpr_to_gpr () +{ + register __int128_t q0 asm ("q0"); + asm volatile ("" : "=w" (q0)); + return q0; +} diff --git a/gcc/testsuite/gcc.target/aarch64/movv16qi_1.c b/gcc/testsuite/gcc.target/aarch64/movv16qi_1.c new file mode 100644 index 0000000..8a6afb1 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movv16qi_1.c @@ -0,0 +1,82 @@ +/* { dg-do assemble } */ +/* { dg-options "-O -mtune=neoverse-v1 --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +typedef unsigned char v16qi __attribute__((vector_size(16))); + +/* +** fpr_to_fpr: +** sub sp, sp, #16 +** str q1, \[sp\] +** ldr q0, \[sp\] +** add sp, sp, #?16 +** ret +*/ +v16qi +fpr_to_fpr (v16qi q0, v16qi q1) +{ + return q1; +} + +/* +** gpr_to_fpr: { target aarch64_little_endian } +** fmov d0, x0 +** fmov v0.d\[1\], x1 +** ret +*/ +/* +** gpr_to_fpr: { target aarch64_big_endian } +** fmov d0, x1 +** fmov v0.d\[1\], x0 +** ret +*/ +v16qi +gpr_to_fpr () +{ + register v16qi x0 asm ("x0"); + asm volatile ("" : "=r" (x0)); + return x0; +} + +/* +** zero_to_fpr: +** fmov d0, xzr +** ret +*/ +v16qi +zero_to_fpr () +{ + return (v16qi) {}; +} + +/* +** fpr_to_gpr: { target aarch64_little_endian } +** ( +** fmov x0, d0 +** fmov x1, v0.d\[1\] +** | +** fmov x1, v0.d\[1\] +** fmov x0, d0 +** ) +** ret +*/ +/* +** fpr_to_gpr: { target aarch64_big_endian } +** ( +** fmov x1, d0 +** fmov x0, v0.d\[1\] +** | +** fmov x0, v0.d\[1\] +** fmov x1, d0 +** ) +** ret +*/ +void +fpr_to_gpr (v16qi q0) +{ + register v16qi x0 asm ("x0"); + x0 = q0; + asm volatile ("" :: "r" (x0)); +} diff --git a/gcc/testsuite/gcc.target/aarch64/movv8qi_1.c b/gcc/testsuite/gcc.target/aarch64/movv8qi_1.c new file mode 100644 index 0000000..4c97e6f --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/movv8qi_1.c @@ -0,0 +1,55 @@ +/* { dg-do assemble } */ +/* { dg-options "-O -mtune=neoverse-v1 --save-temps" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +#pragma GCC target "+nothing+nosimd+fp" + +typedef unsigned char v8qi __attribute__((vector_size(8))); + +/* +** fpr_to_fpr: +** fmov d0, d1 +** ret +*/ +v8qi +fpr_to_fpr (v8qi q0, v8qi q1) +{ + return q1; +} + +/* +** gpr_to_fpr: +** fmov d0, x0 +** ret +*/ +v8qi +gpr_to_fpr () +{ + register v8qi x0 asm ("x0"); + asm volatile ("" : "=r" (x0)); + return x0; +} + +/* +** zero_to_fpr: +** fmov d0, xzr +** ret +*/ +v8qi +zero_to_fpr () +{ + return (v8qi) {}; +} + +/* +** fpr_to_gpr: +** fmov x0, d0 +** ret +*/ +void +fpr_to_gpr (v8qi q0) +{ + register v8qi x0 asm ("x0"); + x0 = q0; + asm volatile ("" :: "r" (x0)); +} diff --git a/gcc/testsuite/gcc.target/aarch64/nofp_2.c b/gcc/testsuite/gcc.target/aarch64/nofp_2.c new file mode 100644 index 0000000..8a262cc --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/nofp_2.c @@ -0,0 +1,19 @@ +/* { dg-options "" } */ + +#pragma GCC target "+nothing+nofp" + +void +test (void) +{ + register int q0 asm ("q0"); // { dg-error "not general enough" } + register int q1 asm ("q1"); // { dg-error "not general enough" } + asm volatile ("" : "=w" (q0)); + q1 = q0; + asm volatile ("" :: "w" (q1)); +} + +void +ok (void) +{ + asm volatile ("" ::: "q0"); +} diff --git a/gcc/testsuite/gcc.target/i386/avx512f-vcvtps2ph-sae.c b/gcc/testsuite/gcc.target/i386/avx512f-vcvtps2ph-sae.c new file mode 100644 index 0000000..e0714d4 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/avx512f-vcvtps2ph-sae.c @@ -0,0 +1,18 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mavx512f" } */ +/* { dg-final { scan-assembler-times "vcvtps2ph\[ \\t\]+\[^\{\n\]*\{sae\}\[^\{\n\]*%ymm\[0-9\]+(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vcvtps2ph\[ \\t\]+\[^\{\n\]*\{sae\}\[^\{\n\]*%ymm\[0-9\]+\{%k\[1-7\]\}(?:\n|\[ \\t\]+#)" 1 } } */ +/* { dg-final { scan-assembler-times "vcvtps2ph\[ \\t\]+\[^\{\n\]*\{sae\}\[^\{\n\]*%ymm\[0-9\]+\{%k\[1-7\]\}\{z\}(?:\n|\[ \\t\]+#)" 1 } } */ + +#include <immintrin.h> + +volatile __m512 x; +volatile __m256i y; + +void extern +avx512f_test (void) +{ + y = _mm512_cvtps_ph (x, 8); + y = _mm512_maskz_cvtps_ph (4, x, 9); + y = _mm512_mask_cvtps_ph (y, 2, x, 10); +} diff --git a/gcc/testsuite/gcc.target/i386/pr103144-mul-1.c b/gcc/testsuite/gcc.target/i386/pr103144-mul-1.c new file mode 100644 index 0000000..640c34f --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr103144-mul-1.c @@ -0,0 +1,51 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mavx2 -ftree-vectorize -fvect-cost-model=unlimited -fdump-tree-vect-details -mprefer-vector-width=256" } */ +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 4 "vect" } } */ + +#define N 10000 + +void +__attribute__((noipa)) +foo_mul (int* a, int b) +{ + for (int i = 0; i != N; i++) + { + a[i] = b; + b *= 3; + } +} + +void +__attribute__((noipa)) +foo_mul_const (int* a) +{ + int b = 1; + for (int i = 0; i != N; i++) + { + a[i] = b; + b *= 3; + } +} + +void +__attribute__((noipa)) +foo_mul_peel (int* a, int b) +{ + for (int i = 0; i != 39; i++) + { + a[i] = b; + b *= 3; + } +} + +void +__attribute__((noipa)) +foo_mul_peel_const (int* a) +{ + int b = 1; + for (int i = 0; i != 39; i++) + { + a[i] = b; + b *= 3; + } +} diff --git a/gcc/testsuite/gcc.target/i386/pr103144-mul-2.c b/gcc/testsuite/gcc.target/i386/pr103144-mul-2.c new file mode 100644 index 0000000..39fdea3 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr103144-mul-2.c @@ -0,0 +1,51 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mavx2 -ftree-vectorize -fvect-cost-model=unlimited -mprefer-vector-width=256" } */ +/* { dg-require-effective-target avx2 } */ + +#include "avx2-check.h" +#include <string.h> +#include "pr103144-mul-1.c" + +typedef int v8si __attribute__((vector_size(32))); + +void +avx2_test (void) +{ + int* epi32_exp = (int*) malloc (N * sizeof (int)); + int* epi32_dst = (int*) malloc (N * sizeof (int)); + + __builtin_memset (epi32_exp, 0, N * sizeof (int)); + int b = 8; + v8si init = __extension__(v8si) { b, b * 3, b * 9, b * 27, b * 81, b * 243, b * 729, b * 2187 }; + + for (int i = 0; i != N / 8; i++) + { + memcpy (epi32_exp + i * 8, &init, 32); + init *= 6561; + } + + foo_mul (epi32_dst, b); + if (__builtin_memcmp (epi32_dst, epi32_exp, N * sizeof (int)) != 0) + __builtin_abort (); + + foo_mul_peel (epi32_dst, b); + if (__builtin_memcmp (epi32_dst, epi32_exp, 39 * 4) != 0) + __builtin_abort (); + + init = __extension__(v8si) { 1, 3, 9, 27, 81, 243, 729, 2187 }; + for (int i = 0; i != N / 8; i++) + { + memcpy (epi32_exp + i * 8, &init, 32); + init *= 6561; + } + + foo_mul_const (epi32_dst); + if (__builtin_memcmp (epi32_dst, epi32_exp, N * sizeof (int)) != 0) + __builtin_abort (); + + foo_mul_peel_const (epi32_dst); + if (__builtin_memcmp (epi32_dst, epi32_exp, 39 * 4) != 0) + __builtin_abort (); + + return; +} diff --git a/gcc/testsuite/gcc.target/i386/pr103144-neg-1.c b/gcc/testsuite/gcc.target/i386/pr103144-neg-1.c new file mode 100644 index 0000000..f87b1d6 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr103144-neg-1.c @@ -0,0 +1,51 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mavx2 -ftree-vectorize -fvect-cost-model=unlimited -fdump-tree-vect-details -mprefer-vector-width=256" } */ +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 4 "vect" } } */ + +#define N 10000 + +void +__attribute__((noipa)) +foo_neg (int* a, int b) +{ + for (int i = 0; i != N; i++) + { + a[i] = b; + b = -b; + } +} + +void +__attribute__((noipa)) +foo_neg_const (int* a) +{ + int b = 1; + for (int i = 0; i != N; i++) + { + a[i] = b; + b = -b; + } +} + +void +__attribute__((noipa)) +foo_neg_peel (int* a, int b, int n) +{ + for (int i = 0; i != n; i++) + { + a[i] = b; + b = -b; + } +} + +void +__attribute__((noipa)) +foo_neg_const_peel (int* a, int n) +{ + int b = 1; + for (int i = 0; i != n; i++) + { + a[i] = b; + b = -b; + } +} diff --git a/gcc/testsuite/gcc.target/i386/pr103144-neg-2.c b/gcc/testsuite/gcc.target/i386/pr103144-neg-2.c new file mode 100644 index 0000000..bb8c22b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr103144-neg-2.c @@ -0,0 +1,44 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mavx2 -ftree-vectorize -fvect-cost-model=unlimited -mprefer-vector-width=256" } */ +/* { dg-require-effective-target avx2 } */ + +#include "avx2-check.h" +#include <string.h> +#include "pr103144-neg-1.c" + +void +avx2_test (void) +{ + int* epi32_exp = (int*) malloc (N * sizeof (int)); + int* epi32_dst = (int*) malloc (N * sizeof (int)); + long long* epi64_exp = (long long*) malloc (N * sizeof (int)); + + __builtin_memset (epi32_exp, 0, N * sizeof (int)); + int b = 100; + + for (int i = 0; i != N / 2; i++) + epi64_exp[i] = ((long long) b) | (((long long) -b) << 32); + + memcpy (epi32_exp, epi64_exp, N * sizeof (int)); + foo_neg (epi32_dst, b); + if (__builtin_memcmp (epi32_dst, epi32_exp, N * sizeof (int)) != 0) + __builtin_abort (); + + foo_neg_peel (epi32_dst, b, 39); + if (__builtin_memcmp (epi32_dst, epi32_exp, 39 * sizeof (int)) != 0) + __builtin_abort (); + + for (int i = 0; i != N / 2; i++) + epi64_exp[i] = ((long long) 1) | (((long long) -1) << 32); + + memcpy (epi32_exp, epi64_exp, N * sizeof (int)); + foo_neg_const (epi32_dst); + if (__builtin_memcmp (epi32_dst, epi32_exp, N * sizeof (int)) != 0) + __builtin_abort (); + + foo_neg_const_peel (epi32_dst, 39); + if (__builtin_memcmp (epi32_dst, epi32_exp, 39 * sizeof (int)) != 0) + __builtin_abort (); + + return; +} diff --git a/gcc/testsuite/gcc.target/i386/pr103144-shift-1.c b/gcc/testsuite/gcc.target/i386/pr103144-shift-1.c new file mode 100644 index 0000000..2a69203 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr103144-shift-1.c @@ -0,0 +1,70 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mavx2 -ftree-vectorize -fvect-cost-model=unlimited -fdump-tree-vect-details -mprefer-vector-width=256" } */ +/* { dg-final { scan-tree-dump-times "vectorized 1 loops" 6 "vect" } } */ + +#define N 10000 +void +__attribute__((noipa)) +foo_shl (int* a, int b) +{ + for (int i = 0; i != N; i++) + { + a[i] = b; + b <<= 1; + } +} + +void +__attribute__((noipa)) +foo_ashr (int* a, int b) +{ + for (int i = 0; i != N; i++) + { + a[i] = b; + b >>= 1; + } +} + +void +__attribute__((noipa)) +foo_lshr (unsigned int* a, unsigned int b) +{ + for (int i = 0; i != N; i++) + { + a[i] = b; + b >>= 1U; + } +} + +void +__attribute__((noipa)) +foo_shl_peel (int* a, int b) +{ + for (int i = 0; i != 39; i++) + { + a[i] = b; + b <<= 1; + } +} + +void +__attribute__((noipa)) +foo_ashr_peel (int* a, int b) +{ + for (int i = 0; i != 39; i++) + { + a[i] = b; + b >>= 1; + } +} + +void +__attribute__((noipa)) +foo_lshr_peel (unsigned int* a, unsigned int b) +{ + for (int i = 0; i != 39; i++) + { + a[i] = b; + b >>= 1U; + } +} diff --git a/gcc/testsuite/gcc.target/i386/pr103144-shift-2.c b/gcc/testsuite/gcc.target/i386/pr103144-shift-2.c new file mode 100644 index 0000000..6f47719 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr103144-shift-2.c @@ -0,0 +1,79 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -mavx2 -ftree-vectorize -fvect-cost-model=unlimited -mprefer-vector-width=256" } */ +/* { dg-require-effective-target avx2 } */ + +#include "avx2-check.h" +#include <string.h> +#include "pr103144-shift-1.c" + +typedef int v8si __attribute__((vector_size(32))); +typedef unsigned int v8usi __attribute__((vector_size(32))); + +void +avx2_test (void) +{ + int* epi32_exp = (int*) malloc (N * sizeof (int)); + int* epi32_dst = (int*) malloc (N * sizeof (int)); + unsigned int* epu32_exp = (unsigned int*) malloc (N * sizeof (int)); + unsigned int* epu32_dst = (unsigned int*) malloc (N * sizeof (int)); + + __builtin_memset (epi32_exp, 0, N * sizeof (int)); + int b = 8; + v8si init = __extension__(v8si) { b, b << 1, b << 2, b << 3, b << 4, b << 5, b << 6, b << 7 }; + + for (int i = 0; i != N / 8; i++) + { + memcpy (epi32_exp + i * 8, &init, 32); + init <<= 8; + } + + foo_shl (epi32_dst, b); + if (__builtin_memcmp (epi32_dst, epi32_exp, N * sizeof (int)) != 0) + __builtin_abort (); + + foo_shl_peel (epi32_dst, b); + if (__builtin_memcmp (epi32_dst, epi32_exp, 39 * sizeof (int)) != 0) + __builtin_abort (); + + b = -11111; + init = __extension__(v8si) { b, b >> 1, b >> 2, b >> 3, b >> 4, b >> 5, b >> 6, b >> 7 }; + for (int i = 0; i != N / 8; i++) + { + memcpy (epi32_exp + i * 8, &init, 32); + init >>= 8; + } + + foo_ashr (epi32_dst, b); + if (__builtin_memcmp (epi32_dst, epi32_exp, N * sizeof (int)) != 0) + __builtin_abort (); + + foo_ashr_peel (epi32_dst, b); + if (__builtin_memcmp (epi32_dst, epi32_exp, 39 * sizeof (int)) != 0) + { + for (int i = 0; i != 39; i++) + { + printf ("epi32_dst[%d] is %d ----", i, epi32_dst[i]); + printf ("epi32_exp[%d] is %d\n", i, epi32_exp[i]); + } + __builtin_abort (); + } + + __builtin_memset (epu32_exp, 0, N * sizeof (int)); + unsigned int c = 11111111; + v8usi initu = __extension__(v8usi) { c, c >> 1U, c >> 2U, c >> 3U, c >> 4U, c >> 5U, c >> 6U, c >> 7U }; + for (int i = 0; i != N / 8; i++) + { + memcpy (epu32_exp + i * 8, &initu, 32); + initu >>= 8U; + } + + foo_lshr (epu32_dst, c); + if (__builtin_memcmp (epu32_dst, epu32_exp, N * sizeof (int)) != 0) + __builtin_abort (); + + foo_lshr_peel (epu32_dst, c); + if (__builtin_memcmp (epu32_dst, epu32_exp, 39 * sizeof (int)) != 0) + __builtin_abort (); + + return; +} diff --git a/gcc/testsuite/gcc.target/powerpc/pr105586.c b/gcc/testsuite/gcc.target/powerpc/pr105586.c new file mode 100644 index 0000000..bd397f5 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/pr105586.c @@ -0,0 +1,19 @@ +/* { dg-options "-mdejagnu-tune=power4 -O2 -fcompare-debug -fno-if-conversion -fno-guess-branch-probability" } */ + +extern int bar(int i); + +typedef unsigned long u64; +int g; + +__int128 h; + +void +foo(int a, int b) { + int i; + char u8_1 = g, u8_3 = a; + u64 u64_1 = bar(0), u64_3 = u8_3 * u64_1; + __int128 u128_1 = h ^ __builtin_expect(i, 0); + u64 u64_4 = u64_1 << ((__builtin_sub_overflow_p(0, u8_1, (u64)0) ^ u128_1) & 8); + u64 u64_r = b + u64_3 + u64_4; + bar((short)u64_r + u8_3); +} diff --git a/gcc/testsuite/gcc.target/powerpc/pr106833.c b/gcc/testsuite/gcc.target/powerpc/pr106833.c new file mode 100644 index 0000000..968d751 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/pr106833.c @@ -0,0 +1,14 @@ +/* { dg-do link } */ +/* { dg-require-effective-target power10_ok } */ +/* { dg-require-effective-target lto } */ +/* { dg-options "-flto -mdejagnu-cpu=power10" } */ + +/* Verify there is no ICE in LTO mode. */ + +int main () +{ + float *b; + const __vector_quad c; + __builtin_mma_disassemble_acc (b, &c); + return 0; +} diff --git a/gcc/testsuite/gcc.target/xtensa/constsynth_3insns.c b/gcc/testsuite/gcc.target/xtensa/constsynth_3insns.c index f3c4a1c..831288c 100644 --- a/gcc/testsuite/gcc.target/xtensa/constsynth_3insns.c +++ b/gcc/testsuite/gcc.target/xtensa/constsynth_3insns.c @@ -21,4 +21,15 @@ void test_3(int *p) *p = 192437; } +struct foo +{ + unsigned int b : 10; + unsigned int g : 11; + unsigned int r : 11; +}; +void test_4(struct foo *p, unsigned int v) +{ + p->g = v; +} + /* { dg-final { scan-assembler-not "l32r" } } */ diff --git a/gcc/testsuite/gfortran.dg/gomp/ompx-1.f90 b/gcc/testsuite/gfortran.dg/gomp/ompx-1.f90 new file mode 100644 index 0000000..e5dc652 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/ompx-1.f90 @@ -0,0 +1,2 @@ +!$ompx foo ! { dg-warning "!.OMP at .1. starts a commented line as it neither is followed by a space nor is a continuation line" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/omx-1.f b/gcc/testsuite/gfortran.dg/gomp/omx-1.f new file mode 100644 index 0000000..4febf89 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omx-1.f @@ -0,0 +1,7 @@ +!$omx foo +!$OMX foo +c$oMx foo +c$OMx foo +*$oMx foo +*$OMx foo + end diff --git a/gcc/testsuite/gfortran.dg/gomp/omx-2.f b/gcc/testsuite/gfortran.dg/gomp/omx-2.f new file mode 100644 index 0000000..3c107d9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omx-2.f @@ -0,0 +1,9 @@ +! { dg-additional-options "-Wsurprising" } + +!$omx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +!$OMX foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +c$oMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +c$OMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +*$oMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +*$OMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } + end diff --git a/gcc/testsuite/gfortran.dg/ieee/fma_1.f90 b/gcc/testsuite/gfortran.dg/ieee/fma_1.f90 new file mode 100644 index 0000000..3463642 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/fma_1.f90 @@ -0,0 +1,100 @@ +! Test IEEE_FMA +! { dg-do run } + + use, intrinsic :: ieee_features + use, intrinsic :: ieee_exceptions + use, intrinsic :: ieee_arithmetic + implicit none + + integer :: ex + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: lx1, lx2, lx3 + real(kind=k2) :: wx1, wx2, wx3 + + ! Float + + sx1 = 3 ; sx2 = 2 ; sx3 = 1 + if (ieee_fma(sx1, sx2, sx3) /= 7) stop 1 + sx1 = 0 ; sx2 = 2 ; sx3 = 1 + if (ieee_fma(sx1, sx2, sx3) /= 1) stop 2 + sx1 = 3 ; sx2 = 2 ; sx3 = 0 + if (ieee_fma(sx1, sx2, sx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(sx1)))) / log(real(2, kind(sx1)))) - 1 + sx1 = 1 + spacing(real(1, kind(sx1))) + sx2 = 2 ; sx2 = sx2 ** ex ; sx2 = sx2 * 3 + sx3 = -sx2 + + print *, sx1 * sx2 + sx3 + print *, ieee_fma(sx1, sx2, sx3) + if (ieee_fma(sx1, sx2, sx3) /= real(3, kind(sx1)) / 2) stop 4 + !if (ieee_fma(sx1, sx2, sx3) == sx1 * sx2 + sx3) stop 5 + + ! Double + + dx1 = 3 ; dx2 = 2 ; dx3 = 1 + if (ieee_fma(dx1, dx2, dx3) /= 7) stop 1 + dx1 = 0 ; dx2 = 2 ; dx3 = 1 + if (ieee_fma(dx1, dx2, dx3) /= 1) stop 2 + dx1 = 3 ; dx2 = 2 ; dx3 = 0 + if (ieee_fma(dx1, dx2, dx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(dx1)))) / log(real(2, kind(dx1)))) - 1 + dx1 = 1 + spacing(real(1, kind(dx1))) + dx2 = 2 ; dx2 = dx2 ** ex ; dx2 = dx2 * 3 + dx3 = -dx2 + + print *, dx1 * dx2 + dx3 + print *, ieee_fma(dx1, dx2, dx3) + if (ieee_fma(dx1, dx2, dx3) /= real(3, kind(dx1)) / 2) stop 4 + !if (ieee_fma(dx1, dx2, dx3) == dx1 * dx2 + dx3) stop 5 + + ! Large kind 1 + + lx1 = 3 ; lx2 = 2 ; lx3 = 1 + if (ieee_fma(lx1, lx2, lx3) /= 7) stop 1 + lx1 = 0 ; lx2 = 2 ; lx3 = 1 + if (ieee_fma(lx1, lx2, lx3) /= 1) stop 2 + lx1 = 3 ; lx2 = 2 ; lx3 = 0 + if (ieee_fma(lx1, lx2, lx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(lx1)))) / log(real(2, kind(lx1)))) - 1 + lx1 = 1 + spacing(real(1, kind(lx1))) + lx2 = 2 ; lx2 = lx2 ** ex ; lx2 = lx2 * 3 + lx3 = -lx2 + + print *, lx1 * lx2 + lx3 + print *, ieee_fma(lx1, lx2, lx3) + if (ieee_fma(lx1, lx2, lx3) /= real(3, kind(lx1)) / 2) stop 4 + if (ieee_fma(lx1, lx2, lx3) == lx1 * lx2 + lx3) stop 5 + + ! Large kind 2 + + wx1 = 3 ; wx2 = 2 ; wx3 = 1 + if (ieee_fma(wx1, wx2, wx3) /= 7) stop 1 + wx1 = 0 ; wx2 = 2 ; wx3 = 1 + if (ieee_fma(wx1, wx2, wx3) /= 1) stop 2 + wx1 = 3 ; wx2 = 2 ; wx3 = 0 + if (ieee_fma(wx1, wx2, wx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(wx1)))) / log(real(2, kind(wx1)))) - 1 + wx1 = 1 + spacing(real(1, kind(wx1))) + wx2 = 2 ; wx2 = wx2 ** ex ; wx2 = wx2 * 3 + wx3 = -wx2 + + print *, wx1 * wx2 + wx3 + print *, ieee_fma(wx1, wx2, wx3) + if (ieee_fma(wx1, wx2, wx3) /= real(3, kind(wx1)) / 2) stop 4 + if (ieee_fma(wx1, wx2, wx3) == wx1 * wx2 + wx3) stop 5 + +end diff --git a/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90 b/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90 new file mode 100644 index 0000000..5d6e41d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/signbit_1.f90 @@ -0,0 +1,166 @@ +! Test IEEE_SIGNBIT +! { dg-do run } + + use, intrinsic :: ieee_features + use, intrinsic :: ieee_exceptions + use, intrinsic :: ieee_arithmetic + implicit none + + real :: sx1 + double precision :: dx1 + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: xk1 + real(kind=k2) :: xk2 + + ! Float + + sx1 = 1.3 + if (ieee_signbit(sx1)) stop 1 + sx1 = huge(sx1) + if (ieee_signbit(sx1)) stop 2 + sx1 = ieee_value(sx1, ieee_positive_inf) + if (ieee_signbit(sx1)) stop 3 + sx1 = tiny(sx1) + if (ieee_signbit(sx1)) stop 4 + sx1 = tiny(sx1) + sx1 = sx1 / 101 + if (ieee_signbit(sx1)) stop 5 + sx1 = 0 + if (ieee_signbit(sx1)) stop 6 + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_signbit(sx1)) stop 7 + + sx1 = -1.3 + if (.not. ieee_signbit(sx1)) stop 8 + sx1 = -huge(sx1) + if (.not. ieee_signbit(sx1)) stop 9 + sx1 = -ieee_value(sx1, ieee_positive_inf) + if (.not. ieee_signbit(sx1)) stop 10 + sx1 = -tiny(sx1) + if (.not. ieee_signbit(sx1)) stop 11 + sx1 = -tiny(sx1) + sx1 = sx1 / 101 + if (.not. ieee_signbit(sx1)) stop 12 + sx1 = 0 + sx1 = -sx1 + if (.not. ieee_signbit(sx1)) stop 13 + sx1 = ieee_value(sx1, ieee_quiet_nan) + sx1 = -sx1 + if (.not. ieee_signbit(sx1)) stop 14 + + ! Double + + dx1 = 1.3 + if (ieee_signbit(dx1)) stop 1 + dx1 = huge(dx1) + if (ieee_signbit(dx1)) stop 2 + dx1 = ieee_value(dx1, ieee_positive_inf) + if (ieee_signbit(dx1)) stop 3 + dx1 = tiny(dx1) + if (ieee_signbit(dx1)) stop 4 + dx1 = tiny(dx1) + dx1 = dx1 / 101 + if (ieee_signbit(dx1)) stop 5 + dx1 = 0 + if (ieee_signbit(dx1)) stop 6 + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_signbit(dx1)) stop 7 + + dx1 = -1.3 + if (.not. ieee_signbit(dx1)) stop 8 + dx1 = -huge(dx1) + if (.not. ieee_signbit(dx1)) stop 9 + dx1 = -ieee_value(dx1, ieee_positive_inf) + if (.not. ieee_signbit(dx1)) stop 10 + dx1 = -tiny(dx1) + if (.not. ieee_signbit(dx1)) stop 11 + dx1 = -tiny(dx1) + dx1 = dx1 / 101 + if (.not. ieee_signbit(dx1)) stop 12 + dx1 = 0 + dx1 = -dx1 + if (.not. ieee_signbit(dx1)) stop 13 + dx1 = ieee_value(dx1, ieee_quiet_nan) + dx1 = -dx1 + if (.not. ieee_signbit(dx1)) stop 14 + + ! Large kind 1 + + xk1 = 1.3 + if (ieee_signbit(xk1)) stop 1 + xk1 = huge(xk1) + if (ieee_signbit(xk1)) stop 2 + xk1 = ieee_value(xk1, ieee_positive_inf) + if (ieee_signbit(xk1)) stop 3 + xk1 = tiny(xk1) + if (ieee_signbit(xk1)) stop 4 + xk1 = tiny(xk1) + xk1 = xk1 / 101 + if (ieee_signbit(xk1)) stop 5 + xk1 = 0 + if (ieee_signbit(xk1)) stop 6 + xk1 = ieee_value(xk1, ieee_quiet_nan) + if (ieee_signbit(xk1)) stop 7 + + xk1 = -1.3 + if (.not. ieee_signbit(xk1)) stop 8 + xk1 = -huge(xk1) + if (.not. ieee_signbit(xk1)) stop 9 + xk1 = -ieee_value(xk1, ieee_positive_inf) + if (.not. ieee_signbit(xk1)) stop 10 + xk1 = -tiny(xk1) + if (.not. ieee_signbit(xk1)) stop 11 + xk1 = -tiny(xk1) + xk1 = xk1 / 101 + if (.not. ieee_signbit(xk1)) stop 12 + xk1 = 0 + xk1 = -xk1 + if (.not. ieee_signbit(xk1)) stop 13 + xk1 = ieee_value(xk1, ieee_quiet_nan) + xk1 = -xk1 + if (.not. ieee_signbit(xk1)) stop 14 + + ! Large kind 2 + + xk2 = 1.3 + if (ieee_signbit(xk2)) stop 1 + xk2 = huge(xk2) + if (ieee_signbit(xk2)) stop 2 + xk2 = ieee_value(xk2, ieee_positive_inf) + if (ieee_signbit(xk2)) stop 3 + xk2 = tiny(xk2) + if (ieee_signbit(xk2)) stop 4 + xk2 = tiny(xk2) + xk2 = xk2 / 101 + if (ieee_signbit(xk2)) stop 5 + xk2 = 0 + if (ieee_signbit(xk2)) stop 6 + xk2 = ieee_value(xk2, ieee_quiet_nan) + if (ieee_signbit(xk2)) stop 7 + + xk2 = -1.3 + if (.not. ieee_signbit(xk2)) stop 8 + xk2 = -huge(xk2) + if (.not. ieee_signbit(xk2)) stop 9 + xk2 = -ieee_value(xk2, ieee_positive_inf) + if (.not. ieee_signbit(xk2)) stop 10 + xk2 = -tiny(xk2) + if (.not. ieee_signbit(xk2)) stop 11 + xk2 = -tiny(xk2) + xk2 = xk2 / 101 + if (.not. ieee_signbit(xk2)) stop 12 + xk2 = 0 + xk2 = -xk2 + if (.not. ieee_signbit(xk2)) stop 13 + xk2 = ieee_value(xk2, ieee_quiet_nan) + xk2 = -xk2 + if (.not. ieee_signbit(xk2)) stop 14 + +end diff --git a/gcc/testsuite/gnat.dg/aspect2.adb b/gcc/testsuite/gnat.dg/aspect2.adb deleted file mode 100644 index acf3329..0000000 --- a/gcc/testsuite/gnat.dg/aspect2.adb +++ /dev/null @@ -1,5 +0,0 @@ --- { dg-do compile } - -package body Aspect2 is - procedure Foo is null; -end Aspect2; diff --git a/gcc/testsuite/gnat.dg/aspect2.ads b/gcc/testsuite/gnat.dg/aspect2.ads deleted file mode 100644 index 73d3fe0..0000000 --- a/gcc/testsuite/gnat.dg/aspect2.ads +++ /dev/null @@ -1,30 +0,0 @@ -with Ada.Containers.Functional_Vectors; -with Ada.Containers; use Ada.Containers; - -generic - type Element_Type (<>) is private; - type Element_Model (<>) is private; - with function Model (X : Element_Type) return Element_Model is <>; - with function Copy (X : Element_Type) return Element_Type is <>; -package Aspect2 with SPARK_Mode is - pragma Unevaluated_Use_Of_Old (Allow); - - type Vector is private; - - function Length (V : Vector) return Natural; - - procedure Foo; - -private - type Element_Access is access Element_Type; - type Element_Array is array (Positive range <>) of Element_Access with - Dynamic_Predicate => Element_Array'First = 1; - type Element_Array_Access is access Element_Array; - type Vector is record - Top : Natural := 0; - Content : Element_Array_Access; - end record; - - function Length (V : Vector) return Natural is - (V.Top); -end Aspect2; diff --git a/gcc/testsuite/gnat.dg/config_pragma1.adb b/gcc/testsuite/gnat.dg/config_pragma1.adb deleted file mode 100644 index bae42d2..0000000 --- a/gcc/testsuite/gnat.dg/config_pragma1.adb +++ /dev/null @@ -1,21 +0,0 @@ --- { dg-do run } --- { dg-options "-gnata" } - -with Ada.Strings.Fixed; use Ada.Strings.Fixed; -with Config_Pragma1_Pkg; use Config_Pragma1_Pkg; - -procedure Config_Pragma1 is - Target : String10; - -begin - for I in Positive10 loop - Move - (Source => Positive10'Image(I), - Target => Target); - - FHM.Include - (Container => FHMM, - Key => Target, - New_Item => I); - end loop; -end Config_Pragma1; diff --git a/gcc/testsuite/gnat.dg/config_pragma1_pkg.ads b/gcc/testsuite/gnat.dg/config_pragma1_pkg.ads deleted file mode 100644 index 1715068..0000000 --- a/gcc/testsuite/gnat.dg/config_pragma1_pkg.ads +++ /dev/null @@ -1,21 +0,0 @@ -pragma Assertion_Policy (Ignore); - -with Ada.Containers; use Ada.Containers; -with Ada.Containers.Formal_Hashed_Maps; -with Ada.Strings; use Ada.Strings; -with Ada.Strings.Hash; - -package Config_Pragma1_Pkg is - subtype Positive10 is Positive range 1 .. 1000; - subtype String10 is String (Positive10); - - package FHM is new Formal_Hashed_Maps - (Key_Type => String10, - Element_Type => Positive10, - Hash => Hash, - Equivalent_Keys => "="); - - FHMM : FHM.Map - (Capacity => 1_000_000, - Modulus => FHM.Default_Modulus (Count_Type (1_000_000))); -end Config_Pragma1_Pkg; diff --git a/gcc/testsuite/gnat.dg/equal8.adb b/gcc/testsuite/gnat.dg/equal8.adb deleted file mode 100644 index 9424abc..0000000 --- a/gcc/testsuite/gnat.dg/equal8.adb +++ /dev/null @@ -1,6 +0,0 @@ --- { dg-do compile } --- { dg-options "-gnata" } - -package body Equal8 is - procedure Foo is null; -end Equal8; diff --git a/gcc/testsuite/gnat.dg/equal8.ads b/gcc/testsuite/gnat.dg/equal8.ads deleted file mode 100644 index 9b6694d..0000000 --- a/gcc/testsuite/gnat.dg/equal8.ads +++ /dev/null @@ -1,36 +0,0 @@ -with Ada.Containers.Formal_Hashed_Sets; -with Ada.Strings.Hash; - --- with Dynamic_Strings; use Dynamic_Strings; --- with Bounded_Dynamic_Strings; - -with Equal8_Pkg; - -package Equal8 is - - package Dynamic_Strings is - -- pragma SPARK_Mode (On); - - package Bounded_Dynamic_Strings is new Equal8_Pkg - (Component => Character, - List_Index => Positive, - List => String, - Default_Value => ' '); - type Dynamic_String is new Bounded_Dynamic_Strings.Sequence; - - end Dynamic_Strings; - use Dynamic_Strings; - - subtype Subscription_Address is Dynamic_String (Capacity => 255); - - function Hashed_Subscription_Address (Element : Subscription_Address) - return Ada.Containers.Hash_Type is - (Ada.Strings.Hash (Value (Element))); - - package Subscription_Addresses is new Ada.Containers.Formal_Hashed_Sets - (Element_Type => Subscription_Address, - Hash => Hashed_Subscription_Address, - Equivalent_Elements => "="); - - procedure Foo; -end Equal8; diff --git a/gcc/testsuite/gnat.dg/equal8_pkg.ads b/gcc/testsuite/gnat.dg/equal8_pkg.ads deleted file mode 100644 index b454a2c..0000000 --- a/gcc/testsuite/gnat.dg/equal8_pkg.ads +++ /dev/null @@ -1,58 +0,0 @@ -generic - type Component is private; - type List_Index is range <>; - type List is array (List_Index range <>) of Component; - Default_Value : Component; - -- with function "=" (Left, Right : List) return Boolean is <>; - -package Equal8_Pkg is - - pragma Pure; - - Maximum_Length : constant List_Index := List_Index'Last; - - subtype Natural_Index is List_Index'Base range 0 .. Maximum_Length; - type Sequence (Capacity : Natural_Index) is private; - -- from zero to Capacity. - - function Value (This : Sequence) return List; - -- Returns the content of this sequence. The value returned is the - -- "logical" value in that only that slice which is currently assigned - -- is returned, as opposed to the entire physical representation. - - overriding - function "=" (Left, Right : Sequence) return Boolean with - Inline; - - function "=" (Left : Sequence; Right : List) return Boolean with - Inline; - -private - type Sequence (Capacity : Natural_Index) is record - Current_Length : Natural_Index := 0; - Content : List (1 .. Capacity) := (others => Default_Value); - end record; - - ----------- - -- Value -- - ----------- - - function Value (This : Sequence) return List is - (This.Content (1 .. This.Current_Length)); - - --------- - -- "=" -- - --------- - - overriding - function "=" (Left, Right : Sequence) return Boolean is - (Value (Left) = Value (Right)); - - --------- - -- "=" -- - --------- - - function "=" (Left : Sequence; Right : List) return Boolean is - (Value (Left) = Right); -end Equal8_Pkg; - diff --git a/gcc/testsuite/gnat.dg/formal_containers.adb b/gcc/testsuite/gnat.dg/formal_containers.adb deleted file mode 100644 index 185b946..0000000 --- a/gcc/testsuite/gnat.dg/formal_containers.adb +++ /dev/null @@ -1,23 +0,0 @@ --- { dg-do compile } - -with Ada.Containers.Formal_Hashed_Sets; - -procedure Formal_Containers is - type T is new Integer; - - function Eq (X : T; Y : T) return Boolean; - - function Hash (X : T) return Ada.Containers.Hash_Type is (0); - - package TSet is new Ada.Containers.Formal_Hashed_Sets - (Element_Type => T, - Hash => Hash, - Equivalent_Elements => Eq); - - S : Tset.Set := TSet.Empty_Set; - - function Eq (X : T; Y : T) return Boolean is - begin - return TSet.Contains (S, X) or TSet.Contains (S, Y); - end Eq; -begin null; end Formal_Containers; diff --git a/gcc/testsuite/gnat.dg/iter1.adb b/gcc/testsuite/gnat.dg/iter1.adb deleted file mode 100644 index a0a69cf..0000000 --- a/gcc/testsuite/gnat.dg/iter1.adb +++ /dev/null @@ -1,20 +0,0 @@ --- { dg-do compile } - -with Ada.Text_IO; - -package body Iter1 is - - type Table is array (Integer range <>) of Float; - My_Table : Table := (1.0, 2.0, 3.0); - - procedure Dummy (L : My_Lists.List) is - begin - for Item : Boolean of L loop -- { dg-error "subtype indication does not match element type" } - Ada.Text_IO.Put_Line (Integer'Image (Item)); - end loop; - - for Item : Boolean of My_Table loop -- { dg-error "subtype indication does not match component type" } - null; - end loop; - end; -end Iter1; diff --git a/gcc/testsuite/gnat.dg/iter1.ads b/gcc/testsuite/gnat.dg/iter1.ads deleted file mode 100644 index 8329f75..0000000 --- a/gcc/testsuite/gnat.dg/iter1.ads +++ /dev/null @@ -1,8 +0,0 @@ -with Ada.Containers.Formal_Doubly_Linked_Lists; - -package Iter1 is - package My_Lists is new Ada.Containers.Formal_Doubly_Linked_Lists - (Element_Type => Integer); - - procedure Dummy (L : My_Lists.List); -end Iter1; diff --git a/gcc/testsuite/lib/target-supports.exp b/gcc/testsuite/lib/target-supports.exp index 1de2e8c..703aba4 100644 --- a/gcc/testsuite/lib/target-supports.exp +++ b/gcc/testsuite/lib/target-supports.exp @@ -6239,9 +6239,12 @@ proc check_effective_target_powerpc_sqrt { } { } return [check_no_compiler_messages powerpc_sqrt object { + void test (void) + { #ifndef _ARCH_PPCSQ #error _ARCH_PPCSQ is not defined #endif + } } {}] } @@ -6349,71 +6352,92 @@ proc check_effective_target_powerpc_p9modulo_ok { } { # as provided by the test. proc check_effective_target_has_arch_pwr5 { } { return [check_no_compiler_messages_nocache arch_pwr5 assembly { + void test (void) + { #ifndef _ARCH_PWR5 #error does not have power5 support. #else /* "has power5 support" */ #endif + } } [current_compiler_flags]] } proc check_effective_target_has_arch_pwr6 { } { return [check_no_compiler_messages_nocache arch_pwr6 assembly { + void test (void) + { #ifndef _ARCH_PWR6 #error does not have power6 support. #else /* "has power6 support" */ #endif + } } [current_compiler_flags]] } proc check_effective_target_has_arch_pwr7 { } { return [check_no_compiler_messages_nocache arch_pwr7 assembly { + void test (void) + { #ifndef _ARCH_PWR7 #error does not have power7 support. #else /* "has power7 support" */ #endif + } } [current_compiler_flags]] } proc check_effective_target_has_arch_pwr8 { } { return [check_no_compiler_messages_nocache arch_pwr8 assembly { + void test (void) + { #ifndef _ARCH_PWR8 #error does not have power8 support. #else /* "has power8 support" */ #endif + } } [current_compiler_flags]] } proc check_effective_target_has_arch_pwr9 { } { return [check_no_compiler_messages_nocache arch_pwr9 assembly { + void test (void) + { #ifndef _ARCH_PWR9 #error does not have power9 support. #else /* "has power9 support" */ #endif + } } [current_compiler_flags]] } proc check_effective_target_has_arch_pwr10 { } { return [check_no_compiler_messages_nocache arch_pwr10 assembly { + void test (void) + { #ifndef _ARCH_PWR10 #error does not have power10 support. #else /* "has power10 support" */ #endif + } } [current_compiler_flags]] } proc check_effective_target_has_arch_ppc64 { } { return [check_no_compiler_messages_nocache arch_ppc64 assembly { + void test (void) + { #ifndef _ARCH_PPC64 #error does not have ppc64 support. #else /* "has ppc64 support" */ #endif + } } [current_compiler_flags]] } @@ -6500,9 +6524,12 @@ proc check_effective_target_powerpc_float128_hw_ok { } { proc check_effective_target_ppc_float128 { } { return [check_no_compiler_messages_nocache ppc_float128 object { + void test (void) + { #ifndef __FLOAT128__ nope no good #endif + } }] } @@ -6510,9 +6537,12 @@ proc check_effective_target_ppc_float128 { } { proc check_effective_target_ppc_float128_insns { } { return [check_no_compiler_messages_nocache ppc_float128 object { + void test (void) + { #ifndef __FLOAT128_HARDWARE__ nope no good #endif + } }] } @@ -6520,9 +6550,12 @@ proc check_effective_target_ppc_float128_insns { } { proc check_effective_target_powerpc_vsx { } { return [check_no_compiler_messages_nocache powerpc_vsx object { + void test (void) + { #ifndef __VSX__ nope no vsx #endif + } }] } diff --git a/gcc/tree-cfg.cc b/gcc/tree-cfg.cc index bbe0835..e39d947 100644 --- a/gcc/tree-cfg.cc +++ b/gcc/tree-cfg.cc @@ -821,8 +821,9 @@ handle_abnormal_edges (basic_block *dispatcher_bbs, basic_block for_bb, else { tree arg = inner ? boolean_true_node : boolean_false_node; - gimple *g = gimple_build_call_internal (IFN_ABNORMAL_DISPATCHER, + gcall *g = gimple_build_call_internal (IFN_ABNORMAL_DISPATCHER, 1, arg); + gimple_call_set_ctrl_altering (g, true); gimple_stmt_iterator gsi = gsi_after_labels (*dispatcher); gsi_insert_after (&gsi, g, GSI_NEW_STMT); diff --git a/gcc/tree-cfgcleanup.cc b/gcc/tree-cfgcleanup.cc index 3535a7e..b4869ae 100644 --- a/gcc/tree-cfgcleanup.cc +++ b/gcc/tree-cfgcleanup.cc @@ -220,9 +220,10 @@ cleanup_call_ctrl_altering_flag (basic_block bb, gimple *bb_end) return; int flags = gimple_call_flags (bb_end); - if (((flags & (ECF_CONST | ECF_PURE)) - && !(flags & ECF_LOOPING_CONST_OR_PURE)) - || (flags & ECF_LEAF)) + if (!(flags & ECF_NORETURN) + && (((flags & (ECF_CONST | ECF_PURE)) + && !(flags & ECF_LOOPING_CONST_OR_PURE)) + || (flags & ECF_LEAF))) gimple_call_set_ctrl_altering (bb_end, false); else { @@ -328,6 +329,10 @@ cleanup_control_flow_bb (basic_block bb) gsi_remove (&gsi, true); if (remove_fallthru_edge (bb->succs)) retval = true; + tree lhs = gimple_call_lhs (stmt); + if (!lhs + || !should_remove_lhs_p (lhs)) + gimple_call_set_ctrl_altering (stmt, true); } return retval; diff --git a/gcc/tree-eh.cc b/gcc/tree-eh.cc index 076ecd3..ae8fa21 100644 --- a/gcc/tree-eh.cc +++ b/gcc/tree-eh.cc @@ -3321,7 +3321,7 @@ lower_resx (basic_block bb, gresx *stmt, int lp_nr; eh_region src_r, dst_r; gimple_stmt_iterator gsi; - gimple *x; + gcall *x; tree fn, src_nr; bool ret = false; @@ -3346,6 +3346,7 @@ lower_resx (basic_block bb, gresx *stmt, fn = builtin_decl_implicit (BUILT_IN_TRAP); x = gimple_build_call (fn, 0); + gimple_call_set_ctrl_altering (x, true); gsi_insert_before (&gsi, x, GSI_SAME_STMT); while (EDGE_COUNT (bb->succs) > 0) @@ -3463,6 +3464,7 @@ lower_resx (basic_block bb, gresx *stmt, fn = builtin_decl_implicit (BUILT_IN_UNWIND_RESUME); x = gimple_build_call (fn, 1, var); + gimple_call_set_ctrl_altering (x, true); gsi_insert_before (&gsi, x, GSI_SAME_STMT); } diff --git a/gcc/tree-predcom.cc b/gcc/tree-predcom.cc index 5d923fb..a6e45e3 100644 --- a/gcc/tree-predcom.cc +++ b/gcc/tree-predcom.cc @@ -1771,10 +1771,24 @@ ref_at_iteration (data_reference_p dr, int iter, ref = TREE_OPERAND (ref, 0); } } - tree addr = fold_build_pointer_plus (DR_BASE_ADDRESS (dr), off); + /* We may not associate the constant offset across the pointer plus + expression because that might form a pointer to before the object + then. But for some cases we can retain that to allow tree_could_trap_p + to return false - see gcc.dg/tree-ssa/predcom-1.c */ + tree addr, alias_ptr; + if (integer_zerop (off)) + { + alias_ptr = fold_convert (reference_alias_ptr_type (ref), coff); + addr = DR_BASE_ADDRESS (dr); + } + else + { + alias_ptr = build_zero_cst (reference_alias_ptr_type (ref)); + off = size_binop (PLUS_EXPR, off, coff); + addr = fold_build_pointer_plus (DR_BASE_ADDRESS (dr), off); + } addr = force_gimple_operand_1 (unshare_expr (addr), stmts, is_gimple_mem_ref_addr, NULL_TREE); - tree alias_ptr = fold_convert (reference_alias_ptr_type (ref), coff); tree type = build_aligned_type (TREE_TYPE (ref), get_object_alignment (ref)); ref = build2 (MEM_REF, type, addr, alias_ptr); diff --git a/gcc/tree-ssa-dce.cc b/gcc/tree-ssa-dce.cc index daf0782..54e5d8c 100644 --- a/gcc/tree-ssa-dce.cc +++ b/gcc/tree-ssa-dce.cc @@ -1313,6 +1313,7 @@ eliminate_unnecessary_stmts (bool aggressive) if (dump_file && (dump_flags & TDF_DETAILS)) fprintf (dump_file, "\nEliminating unnecessary statements:\n"); + bool had_setjmp = cfun->calls_setjmp; clear_special_calls (); /* Walking basic blocks and statements in reverse order avoids @@ -1496,19 +1497,48 @@ eliminate_unnecessary_stmts (bool aggressive) something_changed |= remove_dead_phis (bb); } - - /* Since we don't track liveness of virtual PHI nodes, it is possible that we - rendered some PHI nodes unreachable while they are still in use. - Mark them for renaming. */ + /* First remove queued edges. */ if (!to_remove_edges.is_empty ()) { - basic_block prev_bb; - /* Remove edges. We've delayed this to not get bogus debug stmts during PHI node removal. */ for (unsigned i = 0; i < to_remove_edges.length (); ++i) remove_edge (to_remove_edges[i]); cfg_altered = true; + } + /* When we cleared calls_setjmp we can purge all abnormal edges. Do so. */ + if (cfun->calls_setjmp != had_setjmp) + { + gcc_assert (!cfun->calls_setjmp); + /* Make sure we only remove the edges, not dominated blocks. Using + gimple_purge_dead_abnormal_call_edges would do that and we + cannot free dominators yet. */ + FOR_EACH_BB_FN (bb, cfun) + if (gcall *stmt = safe_dyn_cast <gcall *> (last_stmt (bb))) + if (!stmt_can_make_abnormal_goto (stmt)) + { + edge_iterator ei; + edge e; + for (ei = ei_start (bb->succs); (e = ei_safe_edge (ei)); ) + { + if (e->flags & EDGE_ABNORMAL) + { + if (e->flags & EDGE_FALLTHRU) + e->flags &= ~EDGE_ABNORMAL; + else + remove_edge (e); + cfg_altered = true; + } + else + ei_next (&ei); + } + } + } + + /* Now remove the unreachable blocks. */ + if (cfg_altered) + { + basic_block prev_bb; find_unreachable_blocks (); @@ -1518,9 +1548,13 @@ eliminate_unnecessary_stmts (bool aggressive) { prev_bb = bb->prev_bb; - if (!bitmap_bit_p (bb_contains_live_stmts, bb->index) + if ((bb_contains_live_stmts + && !bitmap_bit_p (bb_contains_live_stmts, bb->index)) || !(bb->flags & BB_REACHABLE)) { + /* Since we don't track liveness of virtual PHI nodes, it is + possible that we rendered some PHI nodes unreachable while + they are still in use. Mark them for renaming. */ for (gphi_iterator gsi = gsi_start_phis (bb); !gsi_end_p (gsi); gsi_next (&gsi)) if (virtual_operand_p (gimple_phi_result (gsi.phi ()))) diff --git a/gcc/tree-ssa-forwprop.cc b/gcc/tree-ssa-forwprop.cc index fdc4bc8..4b693ef 100644 --- a/gcc/tree-ssa-forwprop.cc +++ b/gcc/tree-ssa-forwprop.cc @@ -2661,7 +2661,9 @@ simplify_permutation (gimple_stmt_iterator *gsi) /* Shuffle of a constructor. */ bool ret = false; - tree res_type = TREE_TYPE (arg0); + tree res_type + = build_vector_type (TREE_TYPE (TREE_TYPE (arg0)), + TYPE_VECTOR_SUBPARTS (TREE_TYPE (op2))); tree opt = fold_ternary (VEC_PERM_EXPR, res_type, arg0, arg1, op2); if (!opt || (TREE_CODE (opt) != CONSTRUCTOR && TREE_CODE (opt) != VECTOR_CST)) diff --git a/gcc/tree-ssa-loop-split.cc b/gcc/tree-ssa-loop-split.cc index bccf621..fad4e83 100644 --- a/gcc/tree-ssa-loop-split.cc +++ b/gcc/tree-ssa-loop-split.cc @@ -531,16 +531,17 @@ split_loop (class loop *loop1) tree guard_iv; tree border = NULL_TREE; affine_iv iv; + edge exit1; - if (!single_exit (loop1) + if (!(exit1 = single_exit (loop1)) + || EDGE_COUNT (exit1->src->succs) != 2 /* ??? We could handle non-empty latches when we split the latch edge (not the exit edge), and put the new exit condition in the new block. OTOH this executes some code unconditionally that might have been skipped by the original exit before. */ || !empty_block_p (loop1->latch) || !easy_exit_values (loop1) - || !number_of_iterations_exit (loop1, single_exit (loop1), &niter, - false, true) + || !number_of_iterations_exit (loop1, exit1, &niter, false, true) || niter.cmp == ERROR_MARK /* We can't yet handle loops controlled by a != predicate. */ || niter.cmp == NE_EXPR) @@ -644,10 +645,13 @@ split_loop (class loop *loop1) fix_loop_bb_probability (loop1, loop2, true_edge, false_edge); /* Fix first loop's exit probability after scaling. */ - edge exit_to_latch1 = single_pred_edge (loop1->latch); + edge exit_to_latch1; + if (EDGE_SUCC (exit1->src, 0) == exit1) + exit_to_latch1 = EDGE_SUCC (exit1->src, 1); + else + exit_to_latch1 = EDGE_SUCC (exit1->src, 0); exit_to_latch1->probability *= true_edge->probability; - single_exit (loop1)->probability - = exit_to_latch1->probability.invert (); + exit1->probability = exit_to_latch1->probability.invert (); /* Finally patch out the two copies of the condition to be always true/false (or opposite). */ diff --git a/gcc/tree-vect-loop-manip.cc b/gcc/tree-vect-loop-manip.cc index b68e6cd..74b221a 100644 --- a/gcc/tree-vect-loop-manip.cc +++ b/gcc/tree-vect-loop-manip.cc @@ -1560,15 +1560,28 @@ vect_update_ivs_after_vectorizer (loop_vec_info loop_vinfo, gcc_assert (!tree_is_chrec (step_expr)); init_expr = PHI_ARG_DEF_FROM_EDGE (phi, loop_preheader_edge (loop)); + gimple_seq stmts = NULL; + enum vect_induction_op_type induction_type + = STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (phi_info); - off = fold_build2 (MULT_EXPR, TREE_TYPE (step_expr), - fold_convert (TREE_TYPE (step_expr), niters), - step_expr); - if (POINTER_TYPE_P (type)) - ni = fold_build_pointer_plus (init_expr, off); + if (induction_type == vect_step_op_add) + { + off = fold_build2 (MULT_EXPR, TREE_TYPE (step_expr), + fold_convert (TREE_TYPE (step_expr), niters), + step_expr); + if (POINTER_TYPE_P (type)) + ni = fold_build_pointer_plus (init_expr, off); + else + ni = fold_build2 (PLUS_EXPR, type, + init_expr, fold_convert (type, off)); + } + /* Don't bother call vect_peel_nonlinear_iv_init. */ + else if (induction_type == vect_step_op_neg) + ni = init_expr; else - ni = fold_build2 (PLUS_EXPR, type, - init_expr, fold_convert (type, off)); + ni = vect_peel_nonlinear_iv_init (&stmts, init_expr, + niters, step_expr, + induction_type); var = create_tmp_var (type, "tmp"); @@ -1577,9 +1590,15 @@ vect_update_ivs_after_vectorizer (loop_vec_info loop_vinfo, ni_name = force_gimple_operand (ni, &new_stmts, false, var); /* Exit_bb shouldn't be empty. */ if (!gsi_end_p (last_gsi)) - gsi_insert_seq_after (&last_gsi, new_stmts, GSI_SAME_STMT); + { + gsi_insert_seq_after (&last_gsi, stmts, GSI_SAME_STMT); + gsi_insert_seq_after (&last_gsi, new_stmts, GSI_SAME_STMT); + } else - gsi_insert_seq_before (&last_gsi, new_stmts, GSI_SAME_STMT); + { + gsi_insert_seq_before (&last_gsi, stmts, GSI_SAME_STMT); + gsi_insert_seq_before (&last_gsi, new_stmts, GSI_SAME_STMT); + } /* Fix phi expressions in the successor bb. */ adjust_phi_and_debug_stmts (phi1, update_e, ni_name); diff --git a/gcc/tree-vect-loop.cc b/gcc/tree-vect-loop.cc index 24556b5..8f88f17 100644 --- a/gcc/tree-vect-loop.cc +++ b/gcc/tree-vect-loop.cc @@ -425,6 +425,77 @@ vect_is_simple_iv_evolution (unsigned loop_nb, tree access_fn, tree * init, return true; } +/* Function vect_is_nonlinear_iv_evolution + + Only support nonlinear induction for integer type + 1. neg + 2. mul by constant + 3. lshift/rshift by constant. + + For neg induction, return a fake step as integer -1. */ +static bool +vect_is_nonlinear_iv_evolution (class loop* loop, stmt_vec_info stmt_info, + gphi* loop_phi_node, tree *init, tree *step) +{ + tree init_expr, ev_expr, result, op1, op2; + gimple* def; + + if (gimple_phi_num_args (loop_phi_node) != 2) + return false; + + init_expr = PHI_ARG_DEF_FROM_EDGE (loop_phi_node, loop_preheader_edge (loop)); + ev_expr = PHI_ARG_DEF_FROM_EDGE (loop_phi_node, loop_latch_edge (loop)); + + /* Support nonlinear induction only for integer type. */ + if (!INTEGRAL_TYPE_P (TREE_TYPE (init_expr))) + return false; + + *init = init_expr; + result = PHI_RESULT (loop_phi_node); + + if (TREE_CODE (ev_expr) != SSA_NAME + || ((def = SSA_NAME_DEF_STMT (ev_expr)), false) + || !is_gimple_assign (def)) + return false; + + enum tree_code t_code = gimple_assign_rhs_code (def); + switch (t_code) + { + case NEGATE_EXPR: + if (gimple_assign_rhs1 (def) != result) + return false; + *step = build_int_cst (TREE_TYPE (init_expr), -1); + STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (stmt_info) = vect_step_op_neg; + break; + + case RSHIFT_EXPR: + case LSHIFT_EXPR: + case MULT_EXPR: + op1 = gimple_assign_rhs1 (def); + op2 = gimple_assign_rhs2 (def); + if (TREE_CODE (op2) != INTEGER_CST + || op1 != result) + return false; + *step = op2; + if (t_code == LSHIFT_EXPR) + STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (stmt_info) = vect_step_op_shl; + else if (t_code == RSHIFT_EXPR) + STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (stmt_info) = vect_step_op_shr; + /* NEGATE_EXPR and MULT_EXPR are both vect_step_op_mul. */ + else + STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (stmt_info) = vect_step_op_mul; + break; + + default: + return false; + } + + STMT_VINFO_LOOP_PHI_EVOLUTION_BASE_UNCHANGED (stmt_info) = *init; + STMT_VINFO_LOOP_PHI_EVOLUTION_PART (stmt_info) = *step; + + return true; +} + /* Return true if PHI, described by STMT_INFO, is the inner PHI in what we are assuming is a double reduction. For example, given a structure like this: @@ -513,11 +584,16 @@ vect_analyze_scalar_cycles_1 (loop_vec_info loop_vinfo, class loop *loop, = evolution_part_in_loop_num (access_fn, loop->num); } - if (!access_fn - || vect_inner_phi_in_double_reduction_p (loop_vinfo, phi) - || !vect_is_simple_iv_evolution (loop->num, access_fn, &init, &step) - || (LOOP_VINFO_LOOP (loop_vinfo) != loop - && TREE_CODE (step) != INTEGER_CST)) + if ((!access_fn + || vect_inner_phi_in_double_reduction_p (loop_vinfo, phi) + || !vect_is_simple_iv_evolution (loop->num, access_fn, + &init, &step) + || (LOOP_VINFO_LOOP (loop_vinfo) != loop + && TREE_CODE (step) != INTEGER_CST)) + /* Only handle nonlinear iv for same loop. */ + && (LOOP_VINFO_LOOP (loop_vinfo) != loop + || !vect_is_nonlinear_iv_evolution (loop, stmt_vinfo, + phi, &init, &step))) { worklist.safe_push (stmt_vinfo); continue; @@ -8233,6 +8309,591 @@ vect_can_vectorize_without_simd_p (code_helper code) && vect_can_vectorize_without_simd_p (tree_code (code))); } +/* Create vector init for vectorized iv. */ +static tree +vect_create_nonlinear_iv_init (gimple_seq* stmts, tree init_expr, + tree step_expr, poly_uint64 nunits, + tree vectype, + enum vect_induction_op_type induction_type) +{ + unsigned HOST_WIDE_INT const_nunits; + tree vec_shift, vec_init, new_name; + unsigned i; + tree itype = TREE_TYPE (vectype); + + /* iv_loop is the loop to be vectorized. Create: + vec_init = [X, X+S, X+2*S, X+3*S] (S = step_expr, X = init_expr). */ + new_name = gimple_convert (stmts, itype, init_expr); + switch (induction_type) + { + case vect_step_op_shr: + case vect_step_op_shl: + /* Build the Initial value from shift_expr. */ + vec_init = gimple_build_vector_from_val (stmts, + vectype, + new_name); + vec_shift = gimple_build (stmts, VEC_SERIES_EXPR, vectype, + build_zero_cst (itype), step_expr); + vec_init = gimple_build (stmts, + (induction_type == vect_step_op_shr + ? RSHIFT_EXPR : LSHIFT_EXPR), + vectype, vec_init, vec_shift); + break; + + case vect_step_op_neg: + { + vec_init = gimple_build_vector_from_val (stmts, + vectype, + new_name); + tree vec_neg = gimple_build (stmts, NEGATE_EXPR, + vectype, vec_init); + /* The encoding has 2 interleaved stepped patterns. */ + vec_perm_builder sel (nunits, 2, 3); + sel.quick_grow (6); + for (i = 0; i < 3; i++) + { + sel[2 * i] = i; + sel[2 * i + 1] = i + nunits; + } + vec_perm_indices indices (sel, 2, nunits); + tree perm_mask_even + = vect_gen_perm_mask_checked (vectype, indices); + vec_init = gimple_build (stmts, VEC_PERM_EXPR, + vectype, + vec_init, vec_neg, + perm_mask_even); + } + break; + + case vect_step_op_mul: + { + /* Use unsigned mult to avoid UD integer overflow. */ + gcc_assert (nunits.is_constant (&const_nunits)); + tree utype = unsigned_type_for (itype); + tree uvectype = build_vector_type (utype, + TYPE_VECTOR_SUBPARTS (vectype)); + new_name = gimple_convert (stmts, utype, new_name); + vec_init = gimple_build_vector_from_val (stmts, + uvectype, + new_name); + tree_vector_builder elts (uvectype, const_nunits, 1); + tree elt_step = build_one_cst (utype); + + elts.quick_push (elt_step); + for (i = 1; i < const_nunits; i++) + { + /* Create: new_name_i = new_name + step_expr. */ + elt_step = gimple_build (stmts, MULT_EXPR, + utype, elt_step, step_expr); + elts.quick_push (elt_step); + } + /* Create a vector from [new_name_0, new_name_1, ..., + new_name_nunits-1]. */ + tree vec_mul = gimple_build_vector (stmts, &elts); + vec_init = gimple_build (stmts, MULT_EXPR, uvectype, + vec_init, vec_mul); + vec_init = gimple_convert (stmts, vectype, vec_init); + } + break; + + default: + gcc_unreachable (); + } + + return vec_init; +} + +/* Peel init_expr by skip_niter for induction_type. */ +tree +vect_peel_nonlinear_iv_init (gimple_seq* stmts, tree init_expr, + tree skip_niters, tree step_expr, + enum vect_induction_op_type induction_type) +{ + gcc_assert (TREE_CODE (skip_niters) == INTEGER_CST); + tree type = TREE_TYPE (init_expr); + unsigned prec = TYPE_PRECISION (type); + switch (induction_type) + { + case vect_step_op_neg: + if (TREE_INT_CST_LOW (skip_niters) % 2) + init_expr = gimple_build (stmts, NEGATE_EXPR, type, init_expr); + /* else no change. */ + break; + + case vect_step_op_shr: + case vect_step_op_shl: + skip_niters = gimple_convert (stmts, type, skip_niters); + step_expr = gimple_build (stmts, MULT_EXPR, type, step_expr, skip_niters); + /* When shift mount >= precision, need to avoid UD. + In the original loop, there's no UD, and according to semantic, + init_expr should be 0 for lshr, ashl, and >>= (prec - 1) for ashr. */ + if (!tree_fits_uhwi_p (step_expr) + || tree_to_uhwi (step_expr) >= prec) + { + if (induction_type == vect_step_op_shl + || TYPE_UNSIGNED (type)) + init_expr = build_zero_cst (type); + else + init_expr = gimple_build (stmts, RSHIFT_EXPR, type, + init_expr, + wide_int_to_tree (type, prec - 1)); + } + else + init_expr = gimple_build (stmts, (induction_type == vect_step_op_shr + ? RSHIFT_EXPR : LSHIFT_EXPR), + type, init_expr, step_expr); + break; + + case vect_step_op_mul: + { + tree utype = unsigned_type_for (type); + init_expr = gimple_convert (stmts, utype, init_expr); + unsigned skipn = TREE_INT_CST_LOW (skip_niters); + wide_int begin = wi::to_wide (step_expr); + for (unsigned i = 0; i != skipn - 1; i++) + begin = wi::mul (begin, wi::to_wide (step_expr)); + tree mult_expr = wide_int_to_tree (utype, begin); + init_expr = gimple_build (stmts, MULT_EXPR, utype, init_expr, mult_expr); + init_expr = gimple_convert (stmts, type, init_expr); + } + break; + + default: + gcc_unreachable (); + } + + return init_expr; +} + +/* Create vector step for vectorized iv. */ +static tree +vect_create_nonlinear_iv_step (gimple_seq* stmts, tree step_expr, + poly_uint64 vf, + enum vect_induction_op_type induction_type) +{ + tree expr = build_int_cst (TREE_TYPE (step_expr), vf); + tree new_name = NULL; + /* Step should be pow (step, vf) for mult induction. */ + if (induction_type == vect_step_op_mul) + { + gcc_assert (vf.is_constant ()); + wide_int begin = wi::to_wide (step_expr); + + for (unsigned i = 0; i != vf.to_constant () - 1; i++) + begin = wi::mul (begin, wi::to_wide (step_expr)); + + new_name = wide_int_to_tree (TREE_TYPE (step_expr), begin); + } + else if (induction_type == vect_step_op_neg) + /* Do nothing. */ + ; + else + new_name = gimple_build (stmts, MULT_EXPR, TREE_TYPE (step_expr), + expr, step_expr); + return new_name; +} + +static tree +vect_create_nonlinear_iv_vec_step (loop_vec_info loop_vinfo, + stmt_vec_info stmt_info, + tree new_name, tree vectype, + enum vect_induction_op_type induction_type) +{ + /* No step is needed for neg induction. */ + if (induction_type == vect_step_op_neg) + return NULL; + + tree t = unshare_expr (new_name); + gcc_assert (CONSTANT_CLASS_P (new_name) + || TREE_CODE (new_name) == SSA_NAME); + tree new_vec = build_vector_from_val (vectype, t); + tree vec_step = vect_init_vector (loop_vinfo, stmt_info, + new_vec, vectype, NULL); + return vec_step; +} + +/* Update vectorized iv with vect_step, induc_def is init. */ +static tree +vect_update_nonlinear_iv (gimple_seq* stmts, tree vectype, + tree induc_def, tree vec_step, + enum vect_induction_op_type induction_type) +{ + tree vec_def = induc_def; + switch (induction_type) + { + case vect_step_op_mul: + { + /* Use unsigned mult to avoid UD integer overflow. */ + tree uvectype + = build_vector_type (unsigned_type_for (TREE_TYPE (vectype)), + TYPE_VECTOR_SUBPARTS (vectype)); + vec_def = gimple_convert (stmts, uvectype, vec_def); + vec_step = gimple_convert (stmts, uvectype, vec_step); + vec_def = gimple_build (stmts, MULT_EXPR, uvectype, + vec_def, vec_step); + vec_def = gimple_convert (stmts, vectype, vec_def); + } + break; + + case vect_step_op_shr: + vec_def = gimple_build (stmts, RSHIFT_EXPR, vectype, + vec_def, vec_step); + break; + + case vect_step_op_shl: + vec_def = gimple_build (stmts, LSHIFT_EXPR, vectype, + vec_def, vec_step); + break; + case vect_step_op_neg: + vec_def = induc_def; + /* Do nothing. */ + break; + default: + gcc_unreachable (); + } + + return vec_def; + +} +/* Function vectorizable_induction + + Check if STMT_INFO performs an nonlinear induction computation that can be + vectorized. If VEC_STMT is also passed, vectorize the induction PHI: create + a vectorized phi to replace it, put it in VEC_STMT, and add it to the same + basic block. + Return true if STMT_INFO is vectorizable in this way. */ + +static bool +vectorizable_nonlinear_induction (loop_vec_info loop_vinfo, + stmt_vec_info stmt_info, + gimple **vec_stmt, slp_tree slp_node, + stmt_vector_for_cost *cost_vec) +{ + class loop *loop = LOOP_VINFO_LOOP (loop_vinfo); + unsigned ncopies; + bool nested_in_vect_loop = false; + class loop *iv_loop; + tree vec_def; + edge pe = loop_preheader_edge (loop); + basic_block new_bb; + tree vec_init, vec_step; + tree new_name; + gimple *new_stmt; + gphi *induction_phi; + tree induc_def, vec_dest; + tree init_expr, step_expr; + tree niters_skip; + poly_uint64 vf = LOOP_VINFO_VECT_FACTOR (loop_vinfo); + unsigned i; + gimple_stmt_iterator si; + + gphi *phi = dyn_cast <gphi *> (stmt_info->stmt); + + tree vectype = STMT_VINFO_VECTYPE (stmt_info); + poly_uint64 nunits = TYPE_VECTOR_SUBPARTS (vectype); + enum vect_induction_op_type induction_type + = STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (stmt_info); + + gcc_assert (induction_type > vect_step_op_add); + + if (slp_node) + ncopies = 1; + else + ncopies = vect_get_num_copies (loop_vinfo, vectype); + gcc_assert (ncopies >= 1); + + /* FORNOW. Only handle nonlinear induction in the same loop. */ + if (nested_in_vect_loop_p (loop, stmt_info)) + { + if (dump_enabled_p ()) + dump_printf_loc (MSG_MISSED_OPTIMIZATION, vect_location, + "nonlinear induction in nested loop.\n"); + return false; + } + + iv_loop = loop; + gcc_assert (iv_loop == (gimple_bb (phi))->loop_father); + + /* TODO: Support slp for nonlinear iv. There should be separate vector iv + update for each iv and a permutation to generate wanted vector iv. */ + if (slp_node) + { + if (dump_enabled_p ()) + dump_printf_loc (MSG_MISSED_OPTIMIZATION, vect_location, + "SLP induction not supported for nonlinear" + " induction.\n"); + return false; + } + + /* Init_expr will be update by vect_update_ivs_after_vectorizer, + if niters is unkown: + For shift, when shift mount >= precision, there would be UD. + For mult, don't known how to generate + init_expr * pow (step, niters) for variable niters. + For neg, it should be ok, since niters of vectorized main loop + will always be multiple of 2. */ + if (!LOOP_VINFO_NITERS_KNOWN_P (loop_vinfo) + && induction_type != vect_step_op_neg) + { + if (dump_enabled_p ()) + dump_printf_loc (MSG_MISSED_OPTIMIZATION, vect_location, + "Peeling for epilogue is not supported" + " for nonlinear induction except neg" + " when iteration count is unknown.\n"); + return false; + } + + /* Also doens't support peel for neg when niter is variable. + ??? generate something like niter_expr & 1 ? init_expr : -init_expr? */ + niters_skip = LOOP_VINFO_MASK_SKIP_NITERS (loop_vinfo); + if (niters_skip != NULL_TREE + && TREE_CODE (niters_skip) != INTEGER_CST) + { + if (dump_enabled_p ()) + dump_printf_loc (MSG_MISSED_OPTIMIZATION, vect_location, + "Peeling for alignement is not supported" + " for nonlinear induction when niters_skip" + " is not constant.\n"); + return false; + } + + if (!LOOP_VINFO_NITERS_KNOWN_P (loop_vinfo) + && induction_type == vect_step_op_mul) + if (!INTEGRAL_TYPE_P (TREE_TYPE (vectype))) + { + if (dump_enabled_p ()) + dump_printf_loc (MSG_MISSED_OPTIMIZATION, vect_location, + "floating point nonlinear induction vectorization" + " not supported.\n"); + return false; + } + + step_expr = STMT_VINFO_LOOP_PHI_EVOLUTION_PART (stmt_info); + init_expr = vect_phi_initial_value (phi); + gcc_assert (step_expr != NULL_TREE && init_expr != NULL + && TREE_CODE (step_expr) == INTEGER_CST); + /* step_expr should be aligned with init_expr, + .i.e. uint64 a >> 1, step is int, but vector<uint64> shift is used. */ + step_expr = fold_convert (TREE_TYPE (vectype), step_expr); + + if (TREE_CODE (init_expr) == INTEGER_CST) + init_expr = fold_convert (TREE_TYPE (vectype), init_expr); + else + gcc_assert (tree_nop_conversion_p (TREE_TYPE (vectype), + TREE_TYPE (init_expr))); + + switch (induction_type) + { + case vect_step_op_neg: + if (TREE_CODE (init_expr) != INTEGER_CST + && TREE_CODE (init_expr) != REAL_CST) + { + /* Check for backend support of NEGATE_EXPR and vec_perm. */ + if (!directly_supported_p (NEGATE_EXPR, vectype)) + return false; + + /* The encoding has 2 interleaved stepped patterns. */ + vec_perm_builder sel (nunits, 2, 3); + machine_mode mode = TYPE_MODE (vectype); + sel.quick_grow (6); + for (i = 0; i < 3; i++) + { + sel[i * 2] = i; + sel[i * 2 + 1] = i + nunits; + } + vec_perm_indices indices (sel, 2, nunits); + if (!can_vec_perm_const_p (mode, mode, indices)) + return false; + } + break; + + case vect_step_op_mul: + { + /* Check for backend support of MULT_EXPR. */ + if (!directly_supported_p (MULT_EXPR, vectype)) + return false; + + /* ?? How to construct vector step for variable number vector. + [ 1, step, pow (step, 2), pow (step, 4), .. ]. */ + if (!vf.is_constant ()) + return false; + } + break; + + case vect_step_op_shr: + /* Check for backend support of RSHIFT_EXPR. */ + if (!directly_supported_p (RSHIFT_EXPR, vectype, optab_vector)) + return false; + + /* Don't shift more than type precision to avoid UD. */ + if (!tree_fits_uhwi_p (step_expr) + || maybe_ge (nunits * tree_to_uhwi (step_expr), + TYPE_PRECISION (TREE_TYPE (init_expr)))) + return false; + break; + + case vect_step_op_shl: + /* Check for backend support of RSHIFT_EXPR. */ + if (!directly_supported_p (LSHIFT_EXPR, vectype, optab_vector)) + return false; + + /* Don't shift more than type precision to avoid UD. */ + if (!tree_fits_uhwi_p (step_expr) + || maybe_ge (nunits * tree_to_uhwi (step_expr), + TYPE_PRECISION (TREE_TYPE (init_expr)))) + return false; + + break; + + default: + gcc_unreachable (); + } + + if (!vec_stmt) /* transformation not required. */ + { + unsigned inside_cost = 0, prologue_cost = 0; + /* loop cost for vec_loop. Neg induction doesn't have any + inside_cost. */ + inside_cost = record_stmt_cost (cost_vec, ncopies, vector_stmt, + stmt_info, 0, vect_body); + + /* loop cost for vec_loop. Neg induction doesn't have any + inside_cost. */ + if (induction_type == vect_step_op_neg) + inside_cost = 0; + + /* prologue cost for vec_init and vec_step. */ + prologue_cost = record_stmt_cost (cost_vec, 2, scalar_to_vec, + stmt_info, 0, vect_prologue); + + if (dump_enabled_p ()) + dump_printf_loc (MSG_NOTE, vect_location, + "vect_model_induction_cost: inside_cost = %d, " + "prologue_cost = %d. \n", inside_cost, + prologue_cost); + + STMT_VINFO_TYPE (stmt_info) = induc_vec_info_type; + DUMP_VECT_SCOPE ("vectorizable_nonlinear_induction"); + return true; + } + + /* Transform. */ + + /* Compute a vector variable, initialized with the first VF values of + the induction variable. E.g., for an iv with IV_PHI='X' and + evolution S, for a vector of 4 units, we want to compute: + [X, X + S, X + 2*S, X + 3*S]. */ + + if (dump_enabled_p ()) + dump_printf_loc (MSG_NOTE, vect_location, "transform induction phi.\n"); + + pe = loop_preheader_edge (iv_loop); + /* Find the first insertion point in the BB. */ + basic_block bb = gimple_bb (phi); + si = gsi_after_labels (bb); + + gimple_seq stmts = NULL; + + /* If we are using the loop mask to "peel" for alignment then we need + to adjust the start value here. */ + if (niters_skip != NULL_TREE) + init_expr = vect_peel_nonlinear_iv_init (&stmts, init_expr, niters_skip, + step_expr, induction_type); + + vec_init = vect_create_nonlinear_iv_init (&stmts, init_expr, + step_expr, nunits, vectype, + induction_type); + if (stmts) + { + new_bb = gsi_insert_seq_on_edge_immediate (pe, stmts); + gcc_assert (!new_bb); + } + + stmts = NULL; + new_name = vect_create_nonlinear_iv_step (&stmts, step_expr, + vf, induction_type); + if (stmts) + { + new_bb = gsi_insert_seq_on_edge_immediate (pe, stmts); + gcc_assert (!new_bb); + } + + vec_step = vect_create_nonlinear_iv_vec_step (loop_vinfo, stmt_info, + new_name, vectype, + induction_type); + /* Create the following def-use cycle: + loop prolog: + vec_init = ... + vec_step = ... + loop: + vec_iv = PHI <vec_init, vec_loop> + ... + STMT + ... + vec_loop = vec_iv + vec_step; */ + + /* Create the induction-phi that defines the induction-operand. */ + vec_dest = vect_get_new_vect_var (vectype, vect_simple_var, "vec_iv_"); + induction_phi = create_phi_node (vec_dest, iv_loop->header); + induc_def = PHI_RESULT (induction_phi); + + /* Create the iv update inside the loop. */ + stmts = NULL; + vec_def = vect_update_nonlinear_iv (&stmts, vectype, + induc_def, vec_step, + induction_type); + + gsi_insert_seq_before (&si, stmts, GSI_SAME_STMT); + new_stmt = SSA_NAME_DEF_STMT (vec_def); + + /* Set the arguments of the phi node: */ + add_phi_arg (induction_phi, vec_init, pe, UNKNOWN_LOCATION); + add_phi_arg (induction_phi, vec_def, loop_latch_edge (iv_loop), + UNKNOWN_LOCATION); + + STMT_VINFO_VEC_STMTS (stmt_info).safe_push (induction_phi); + *vec_stmt = induction_phi; + + /* In case that vectorization factor (VF) is bigger than the number + of elements that we can fit in a vectype (nunits), we have to generate + more than one vector stmt - i.e - we need to "unroll" the + vector stmt by a factor VF/nunits. For more details see documentation + in vectorizable_operation. */ + + if (ncopies > 1) + { + stmts = NULL; + /* FORNOW. This restriction should be relaxed. */ + gcc_assert (!nested_in_vect_loop); + + new_name = vect_create_nonlinear_iv_step (&stmts, step_expr, + nunits, induction_type); + + vec_step = vect_create_nonlinear_iv_vec_step (loop_vinfo, stmt_info, + new_name, vectype, + induction_type); + vec_def = induc_def; + for (i = 1; i < ncopies; i++) + { + /* vec_i = vec_prev + vec_step. */ + stmts = NULL; + vec_def = vect_update_nonlinear_iv (&stmts, vectype, + vec_def, vec_step, + induction_type); + gsi_insert_seq_before (&si, stmts, GSI_SAME_STMT); + new_stmt = SSA_NAME_DEF_STMT (vec_def); + STMT_VINFO_VEC_STMTS (stmt_info).safe_push (new_stmt); + } + } + + if (dump_enabled_p ()) + dump_printf_loc (MSG_NOTE, vect_location, + "transform induction: created def-use cycle: %G%G", + (gimple *) induction_phi, SSA_NAME_DEF_STMT (vec_def)); + + return true; +} + /* Function vectorizable_induction Check if STMT_INFO performs an induction computation that can be vectorized. @@ -8263,6 +8924,8 @@ vectorizable_induction (loop_vec_info loop_vinfo, unsigned i; tree expr; gimple_stmt_iterator si; + enum vect_induction_op_type induction_type + = STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (stmt_info); gphi *phi = dyn_cast <gphi *> (stmt_info->stmt); if (!phi) @@ -8275,6 +8938,11 @@ vectorizable_induction (loop_vec_info loop_vinfo, if (STMT_VINFO_DEF_TYPE (stmt_info) != vect_induction_def) return false; + /* Handle nonlinear induction in a separate place. */ + if (induction_type != vect_step_op_add) + return vectorizable_nonlinear_induction (loop_vinfo, stmt_info, + vec_stmt, slp_node, cost_vec); + tree vectype = STMT_VINFO_VECTYPE (stmt_info); poly_uint64 nunits = TYPE_VECTOR_SUBPARTS (vectype); diff --git a/gcc/tree-vect-slp.cc b/gcc/tree-vect-slp.cc index b10f69d..ca3422c 100644 --- a/gcc/tree-vect-slp.cc +++ b/gcc/tree-vect-slp.cc @@ -5212,7 +5212,7 @@ vect_optimize_slp_pass::get_result_with_layout (slp_tree node, if (SLP_TREE_SCALAR_STMTS (node).length ()) { auto &stmts = SLP_TREE_SCALAR_STMTS (result); - stmts.safe_splice (SLP_TREE_SCALAR_STMTS (result)); + stmts.safe_splice (SLP_TREE_SCALAR_STMTS (node)); if (from_layout_i != 0) vect_slp_permute (m_perms[from_layout_i], stmts, false); if (to_layout_i != 0) @@ -5799,6 +5799,15 @@ vect_detect_hybrid_slp (loop_vec_info loop_vinfo) to use walk_gimple_op. */ wi.is_lhs = 0; walk_gimple_op (stmt_info->stmt, vect_detect_hybrid_slp, &wi); + /* For gather/scatter make sure to walk the offset operand, that + can be a scaling and conversion away. */ + gather_scatter_info gs_info; + if (STMT_VINFO_GATHER_SCATTER_P (stmt_info) + && vect_check_gather_scatter (stmt_info, loop_vinfo, &gs_info)) + { + int dummy; + vect_detect_hybrid_slp (&gs_info.offset, &dummy, &wi); + } } } diff --git a/gcc/tree-vectorizer.h b/gcc/tree-vectorizer.h index a2b0afb..5e75ed1 100644 --- a/gcc/tree-vectorizer.h +++ b/gcc/tree-vectorizer.h @@ -68,6 +68,15 @@ enum vect_def_type { vect_unknown_def_type }; +/* Define operation type of linear/non-linear induction variable. */ +enum vect_induction_op_type { + vect_step_op_add = 0, + vect_step_op_neg, + vect_step_op_mul, + vect_step_op_shl, + vect_step_op_shr +}; + /* Define type of reduction. */ enum vect_reduction_type { TREE_CODE_REDUCTION, @@ -1190,6 +1199,7 @@ public: the version here. */ tree loop_phi_evolution_base_unchanged; tree loop_phi_evolution_part; + enum vect_induction_op_type loop_phi_evolution_type; /* Used for various bookkeeping purposes, generally holding a pointer to some other stmt S that is in some way "related" to this stmt. @@ -1423,6 +1433,7 @@ struct gather_scatter_info { ((S)->dr_aux.dr && DR_GROUP_FIRST_ELEMENT(S)) #define STMT_VINFO_LOOP_PHI_EVOLUTION_BASE_UNCHANGED(S) (S)->loop_phi_evolution_base_unchanged #define STMT_VINFO_LOOP_PHI_EVOLUTION_PART(S) (S)->loop_phi_evolution_part +#define STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE(S) (S)->loop_phi_evolution_type #define STMT_VINFO_MIN_NEG_DIST(S) (S)->min_neg_dist #define STMT_VINFO_REDUC_TYPE(S) (S)->reduc_type #define STMT_VINFO_REDUC_CODE(S) (S)->reduc_code @@ -2329,6 +2340,10 @@ extern int vect_get_known_peeling_cost (loop_vec_info, int, int *, stmt_vector_for_cost *); extern tree cse_and_gimplify_to_preheader (loop_vec_info, tree); +/* Nonlinear induction. */ +extern tree vect_peel_nonlinear_iv_init (gimple_seq*, tree, tree, + tree, enum vect_induction_op_type); + /* In tree-vect-slp.cc. */ extern void vect_slp_init (void); extern void vect_slp_fini (void); diff --git a/gcc/tree.cc b/gcc/tree.cc index 2f488e4..0546c8f 100644 --- a/gcc/tree.cc +++ b/gcc/tree.cc @@ -13680,6 +13680,71 @@ gimple_canonical_types_compatible_p (const_tree t1, const_tree t2, } } +/* For OPAQUE_TYPE T, it should have only size and alignment information + and its mode should be of class MODE_OPAQUE. This function verifies + these properties of T match TV which is the main variant of T and TC + which is the canonical of T. */ + +static void +verify_opaque_type (const_tree t, tree tv, tree tc) +{ + gcc_assert (OPAQUE_TYPE_P (t)); + gcc_assert (tv && tv == TYPE_MAIN_VARIANT (tv)); + gcc_assert (tc && tc == TYPE_CANONICAL (tc)); + + /* For an opaque type T1, check if some of its properties match + the corresponding ones of the other opaque type T2, emit some + error messages for those inconsistent ones. */ + auto check_properties_for_opaque_type = [](const_tree t1, tree t2, + const char *kind_msg) + { + if (!OPAQUE_TYPE_P (t2)) + { + error ("type %s is not an opaque type", kind_msg); + debug_tree (t2); + return; + } + if (!OPAQUE_MODE_P (TYPE_MODE (t2))) + { + error ("type %s is not with opaque mode", kind_msg); + debug_tree (t2); + return; + } + if (TYPE_MODE (t1) != TYPE_MODE (t2)) + { + error ("type %s differs by %<TYPE_MODE%>", kind_msg); + debug_tree (t2); + return; + } + poly_uint64 t1_size = tree_to_poly_uint64 (TYPE_SIZE (t1)); + poly_uint64 t2_size = tree_to_poly_uint64 (TYPE_SIZE (t2)); + if (maybe_ne (t1_size, t2_size)) + { + error ("type %s differs by %<TYPE_SIZE%>", kind_msg); + debug_tree (t2); + return; + } + if (TYPE_ALIGN (t1) != TYPE_ALIGN (t2)) + { + error ("type %s differs by %<TYPE_ALIGN%>", kind_msg); + debug_tree (t2); + return; + } + if (TYPE_USER_ALIGN (t1) != TYPE_USER_ALIGN (t2)) + { + error ("type %s differs by %<TYPE_USER_ALIGN%>", kind_msg); + debug_tree (t2); + return; + } + }; + + if (t != tv) + check_properties_for_opaque_type (t, tv, "variant"); + + if (t != tc) + check_properties_for_opaque_type (t, tc, "canonical"); +} + /* Verify type T. */ void @@ -13687,6 +13752,14 @@ verify_type (const_tree t) { bool error_found = false; tree mv = TYPE_MAIN_VARIANT (t); + tree ct = TYPE_CANONICAL (t); + + if (OPAQUE_TYPE_P (t)) + { + verify_opaque_type (t, mv, ct); + return; + } + if (!mv) { error ("main variant is not defined"); @@ -13701,7 +13774,6 @@ verify_type (const_tree t) else if (t != mv && !verify_type_variant (t, mv)) error_found = true; - tree ct = TYPE_CANONICAL (t); if (!ct) ; else if (TYPE_CANONICAL (ct) != ct) diff --git a/gcc/value-range.cc b/gcc/value-range.cc index c3f668a..adcaaa2 100644 --- a/gcc/value-range.cc +++ b/gcc/value-range.cc @@ -274,7 +274,7 @@ frange::set_nan (fp_prop::kind k) { if (k == fp_prop::YES) { - if (get_nan ().no_p ()) + if (!maybe_nan ()) { set_undefined (); return; @@ -284,7 +284,7 @@ frange::set_nan (fp_prop::kind k) return; } - if (k == fp_prop::NO && get_nan ().yes_p ()) + if (k == fp_prop::NO && known_nan ()) { set_undefined (); return; @@ -308,21 +308,18 @@ frange::set_signbit (fp_prop::kind k) gcc_checking_assert (m_type); // No additional adjustments are needed for a NAN. - if (get_nan ().yes_p ()) + if (known_nan ()) { m_props.set_signbit (k); return; } // Ignore sign changes when they're set correctly. - if (real_less (&m_max, &dconst0)) - { - gcc_checking_assert (get_signbit ().yes_p ()); - return; - } - if (real_less (&dconst0, &m_min)) + if (!maybe_nan ()) { - gcc_checking_assert (get_signbit ().no_p ()); - return; + if (real_less (&m_max, &dconst0)) + return; + if (real_less (&dconst0, &m_min)) + return; } // Adjust the range depending on the sign bit. if (k == fp_prop::YES) @@ -330,17 +327,22 @@ frange::set_signbit (fp_prop::kind k) // Crop the range to [-INF, 0]. frange crop (m_type, dconstninf, dconst0); intersect (crop); - m_props.set_signbit (fp_prop::YES); + if (!undefined_p ()) + m_props.set_signbit (fp_prop::YES); } else if (k == fp_prop::NO) { // Crop the range to [0, +INF]. frange crop (m_type, dconst0, dconstinf); intersect (crop); - m_props.set_signbit (fp_prop::NO); + if (!undefined_p ()) + m_props.set_signbit (fp_prop::NO); } else - m_props.set_signbit (fp_prop::VARYING); + { + m_props.set_signbit (fp_prop::VARYING); + normalize_kind (); + } if (flag_checking) verify_range (); @@ -467,7 +469,7 @@ frange::union_ (const vrange &v) // If one side has a NAN, the union is the other side, plus the union // of the properties and the possibility of a NAN. - if (get_nan ().yes_p ()) + if (known_nan ()) { frange_props save = m_props; *this = r; @@ -478,7 +480,7 @@ frange::union_ (const vrange &v) verify_range (); return true; } - if (r.get_nan ().yes_p ()) + if (r.known_nan ()) { m_props.union_ (r.m_props); set_nan (fp_prop::VARYING); @@ -525,7 +527,7 @@ frange::intersect (const vrange &v) // If two NANs are not exactly the same, drop to an unknown NAN, // otherwise there's nothing to do. - if (get_nan ().yes_p () && r.get_nan ().yes_p ()) + if (known_nan () && r.known_nan ()) { if (m_props == r.m_props) return false; @@ -534,7 +536,7 @@ frange::intersect (const vrange &v) return true; } // ?? Perhaps the intersection of a NAN and anything is a NAN ??. - if (get_nan ().yes_p () || r.get_nan ().yes_p ()) + if (known_nan () || r.known_nan ()) { set_varying (m_type); return true; @@ -590,8 +592,7 @@ frange::operator== (const frange &src) const if (varying_p ()) return types_compatible_p (m_type, src.m_type); - if (m_props.get_nan ().yes_p () - || src.m_props.get_nan ().yes_p ()) + if (known_nan () || src.known_nan ()) return false; return (real_identical (&m_min, &src.m_min) @@ -621,6 +622,9 @@ frange::contains_p (tree cst) const { if (HONOR_SIGNED_ZEROS (m_type) && real_iszero (rv)) { + // FIXME: This is still using get_signbit() instead of + // known_signbit() because the latter bails on possible NANs + // (for now). if (get_signbit ().yes_p ()) return real_isneg (rv); else if (get_signbit ().no_p ()) @@ -644,22 +648,25 @@ frange::singleton_p (tree *result) const if (m_kind == VR_RANGE && real_identical (&m_min, &m_max)) { // Return false for any singleton that may be a NAN. - if (HONOR_NANS (m_type) && !get_nan ().no_p ()) + if (HONOR_NANS (m_type) && maybe_nan ()) return false; // Return the appropriate zero if known. if (HONOR_SIGNED_ZEROS (m_type) && zero_p ()) { - if (get_signbit ().no_p ()) + bool signbit; + if (known_signbit (signbit)) { - if (result) - *result = build_real (m_type, dconst0); - return true; - } - if (get_signbit ().yes_p ()) - { - if (result) - *result = build_real (m_type, real_value_negate (&dconst0)); + if (signbit) + { + if (result) + *result = build_real (m_type, real_value_negate (&dconst0)); + } + else + { + if (result) + *result = build_real (m_type, dconst0); + } return true; } return false; @@ -701,7 +708,7 @@ frange::verify_range () { // If either is a NAN, both must be a NAN. gcc_checking_assert (real_identical (&m_min, &m_max)); - gcc_checking_assert (get_nan ().yes_p ()); + gcc_checking_assert (known_nan ()); } else // Make sure we don't have swapped ranges. @@ -710,7 +717,7 @@ frange::verify_range () // If we're absolutely sure we have a NAN, the endpoints should // reflect this, otherwise we'd have more than one way to represent // a NAN. - if (m_props.get_nan ().yes_p ()) + if (known_nan ()) { gcc_checking_assert (real_isnan (&m_min)); gcc_checking_assert (real_isnan (&m_max)); @@ -718,10 +725,14 @@ frange::verify_range () else { // Make sure the signbit and range agree. - if (m_props.get_signbit ().yes_p ()) - gcc_checking_assert (real_compare (LE_EXPR, &m_max, &dconst0)); - else if (m_props.get_signbit ().no_p ()) - gcc_checking_assert (real_compare (GE_EXPR, &m_min, &dconst0)); + bool signbit; + if (known_signbit (signbit)) + { + if (signbit) + gcc_checking_assert (real_compare (LE_EXPR, &m_max, &dconst0)); + else + gcc_checking_assert (real_compare (GE_EXPR, &m_min, &dconst0)); + } } // If all the properties are clear, we better not span the entire @@ -3637,7 +3648,7 @@ range_tests_nan () ASSERT_FALSE (r0 == r0); ASSERT_TRUE (r0 != r0); - // [5,6] U NAN is [5,6] with an unknown NAN bit. + // [5,6] U NAN. r0 = frange_float ("5", "6"); r0.set_nan (fp_prop::NO); r1 = frange_nan (float_type_node); @@ -3646,7 +3657,7 @@ range_tests_nan () real_from_string (&r, "6"); ASSERT_TRUE (real_identical (&q, &r0.lower_bound ())); ASSERT_TRUE (real_identical (&r, &r0.upper_bound ())); - ASSERT_TRUE (r0.get_nan ().varying_p ()); + ASSERT_TRUE (r0.maybe_nan ()); // NAN U NAN = NAN r0 = frange_nan (float_type_node); @@ -3654,7 +3665,7 @@ range_tests_nan () r0.union_ (r1); ASSERT_TRUE (real_isnan (&r0.lower_bound ())); ASSERT_TRUE (real_isnan (&r1.upper_bound ())); - ASSERT_TRUE (r0.get_nan ().yes_p ()); + ASSERT_TRUE (r0.known_nan ()); // [INF, INF] ^ NAN = VARYING r0 = frange_nan (float_type_node); @@ -3666,18 +3677,18 @@ range_tests_nan () r0 = frange_nan (float_type_node); r1 = frange_nan (float_type_node); r0.intersect (r1); - ASSERT_TRUE (r0.get_nan ().yes_p ()); + ASSERT_TRUE (r0.known_nan ()); // VARYING ^ NAN = NAN. r0 = frange_nan (float_type_node); r1.set_varying (float_type_node); r0.intersect (r1); - ASSERT_TRUE (r0.get_nan ().yes_p ()); + ASSERT_TRUE (r0.known_nan ()); // Setting the NAN bit to yes, forces to range to [NAN, NAN]. r0.set_varying (float_type_node); r0.set_nan (fp_prop::YES); - ASSERT_TRUE (r0.get_nan ().yes_p ()); + ASSERT_TRUE (r0.known_nan ()); ASSERT_TRUE (real_isnan (&r0.lower_bound ())); ASSERT_TRUE (real_isnan (&r0.upper_bound ())); } @@ -3689,6 +3700,7 @@ range_tests_signed_zeros () tree neg_zero = fold_build1 (NEGATE_EXPR, float_type_node, zero); REAL_VALUE_TYPE q, r; frange r0, r1; + bool signbit; // Since -0.0 == +0.0, a range of [-0.0, -0.0] should contain +0.0 // and vice versa. @@ -3722,7 +3734,7 @@ range_tests_signed_zeros () r1 = frange (zero, zero); r1.set_signbit (fp_prop::YES); r0.union_ (r1); - ASSERT_TRUE (r0.zero_p () && r0.get_signbit ().varying_p ()); + ASSERT_TRUE (r0.zero_p () && !r0.known_signbit (signbit)); // NAN U [5,6] should be [5,6] with no sign info. r0 = frange_nan (float_type_node); @@ -3732,13 +3744,14 @@ range_tests_signed_zeros () real_from_string (&r, "6"); ASSERT_TRUE (real_identical (&q, &r0.lower_bound ())); ASSERT_TRUE (real_identical (&r, &r0.upper_bound ())); - ASSERT_TRUE (r0.get_signbit ().varying_p ()); + ASSERT_TRUE (!r0.known_signbit (signbit)); } static void range_tests_signbit () { frange r0, r1; + bool signbit; // Setting the signbit drops the range to [-INF, 0]. r0.set_varying (float_type_node); @@ -3750,35 +3763,42 @@ range_tests_signbit () // the signbit property set. r0 = frange_float ("-5", "10"); r0.set_signbit (fp_prop::YES); - ASSERT_TRUE (r0.get_signbit ().yes_p ()); + r0.set_nan (fp_prop::NO); + ASSERT_TRUE (r0.known_signbit (signbit) && signbit); r1 = frange_float ("-5", "0"); ASSERT_TRUE (real_identical (&r0.lower_bound (), &r1.lower_bound ())); ASSERT_TRUE (real_identical (&r0.upper_bound (), &r1.upper_bound ())); // Negative numbers should have the SIGNBIT set. r0 = frange_float ("-5", "-1"); - ASSERT_TRUE (r0.get_signbit ().yes_p ()); + r0.set_nan (fp_prop::NO); + ASSERT_TRUE (r0.known_signbit (signbit) && signbit); // Positive numbers should have the SIGNBIT clear. r0 = frange_float ("1", "10"); - ASSERT_TRUE (r0.get_signbit ().no_p ()); + r0.set_nan (fp_prop::NO); + ASSERT_TRUE (r0.known_signbit (signbit) && !signbit); // Numbers containing zero should have an unknown SIGNBIT. r0 = frange_float ("0", "10"); - ASSERT_TRUE (r0.get_signbit ().varying_p ()); + r0.set_nan (fp_prop::NO); + ASSERT_TRUE (!r0.known_signbit (signbit)); // Numbers spanning both positive and negative should have an // unknown SIGNBIT. r0 = frange_float ("-10", "10"); - ASSERT_TRUE (r0.get_signbit ().varying_p ()); + r0.set_nan (fp_prop::NO); + ASSERT_TRUE (!r0.known_signbit (signbit)); r0.set_varying (float_type_node); - ASSERT_TRUE (r0.get_signbit ().varying_p ()); + ASSERT_TRUE (!r0.known_signbit (signbit)); // Ignore signbit changes when the sign bit is obviously known from // the range. r0 = frange_float ("5", "10"); + r0.set_nan (fp_prop::NO); r0.set_signbit (fp_prop::VARYING); - ASSERT_TRUE (r0.get_signbit ().no_p ()); + ASSERT_TRUE (r0.known_signbit (signbit) && !signbit); r0 = frange_float ("-5", "-1"); r0.set_signbit (fp_prop::NO); - ASSERT_TRUE (r0.get_signbit ().yes_p ()); + r0.set_nan (fp_prop::NO); + ASSERT_TRUE (r0.undefined_p ()); } static void @@ -3795,7 +3815,7 @@ range_tests_floats () // A range of [-INF,+INF] is actually VARYING if no other properties // are set. r0 = frange_float ("-Inf", "+Inf"); - if (r0.get_nan ().varying_p ()) + if (r0.maybe_nan ()) ASSERT_TRUE (r0.varying_p ()); // ...unless it has some special property... r0.set_nan (fp_prop::NO); diff --git a/gcc/value-range.h b/gcc/value-range.h index 645dc76..f9a01ee 100644 --- a/gcc/value-range.h +++ b/gcc/value-range.h @@ -330,6 +330,7 @@ private: class frange : public vrange { friend class frange_storage_slot; + friend class vrange_printer; public: frange (); frange (const frange &); @@ -366,12 +367,20 @@ public: const REAL_VALUE_TYPE &lower_bound () const; const REAL_VALUE_TYPE &upper_bound () const; + // fpclassify like API + bool known_finite () const; + bool maybe_inf () const; + bool known_inf () const; + bool maybe_nan () const; + bool known_nan () const; + bool known_signbit (bool &signbit) const; + // Accessors for FP properties. - fp_prop get_nan () const { return m_props.get_nan (); } void set_nan (fp_prop::kind f); - fp_prop get_signbit () const { return m_props.get_signbit (); } void set_signbit (fp_prop::kind); private: + fp_prop get_nan () const { return m_props.get_nan (); } + fp_prop get_signbit () const { return m_props.get_signbit (); } void verify_range (); bool normalize_kind (); @@ -1187,4 +1196,69 @@ frange_nan (tree type) return frange (type, r, r); } +// Return TRUE if range is known to be finite. + +inline bool +frange::known_finite () const +{ + if (undefined_p () || varying_p () || m_kind == VR_ANTI_RANGE) + return false; + return (!real_isnan (&m_min) + && !real_isinf (&m_min) + && !real_isinf (&m_max)); +} + +// Return TRUE if range may be infinite. + +inline bool +frange::maybe_inf () const +{ + if (undefined_p () || m_kind == VR_ANTI_RANGE) + return false; + if (varying_p ()) + return true; + return real_isinf (&m_min) || real_isinf (&m_max); +} + +// Return TRUE if range is known to be the [-INF,-INF] or [+INF,+INF]. + +inline bool +frange::known_inf () const +{ + return (m_kind == VR_RANGE + && real_identical (&m_min, &m_max) + && real_isinf (&m_min)); +} + +// Return TRUE if range is possibly a NAN. + +inline bool +frange::maybe_nan () const +{ + return !get_nan ().no_p (); +} + +// Return TRUE if range is a +NAN or -NAN. + +inline bool +frange::known_nan () const +{ + return get_nan ().yes_p (); +} + +// If the signbit for the range is known, set it in SIGNBIT and return +// TRUE. + +inline bool +frange::known_signbit (bool &signbit) const +{ + // FIXME: Signed NANs are not supported yet. + if (maybe_nan ()) + return false; + if (get_signbit ().varying_p ()) + return false; + signbit = get_signbit ().yes_p (); + return true; +} + #endif // GCC_VALUE_RANGE_H |