Merge from trunk revision fba228e259dd5112851527f2dbb62c5601100985.
diff --git a/ChangeLog b/ChangeLog
index 810b906..913f9a6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,19 @@
+2021-09-29 Jonathan Wakely <jwakely@redhat.com>
+
+ * MAINTAINERS: Add myself to DCO section.
+
+2021-09-28 Andrew Burgess <andrew.burgess@embecosm.com>
+
+ * configure: Regenerate.
+ * configure.ac (skipdirs): Add the contents of target_configdirs if
+ we are not building gcc.
+
+2021-09-24 Andrew Burgess <andrew.burgess@embecosm.com>
+
+ * Makefile.def: Back-port commits ba4d88ad892f and
+ 755ba58ebef0 from binutils-gdb repository.
+ * Makefile.in: Regenerated.
+
2021-09-20 Harald Anlauf <anlauf@gmx.de>
* MAINTAINERS (Reviewers): Add myself as Fortran reviewer.
diff --git a/MAINTAINERS b/MAINTAINERS
index 06b00a5..bf4006c 100644
--- a/MAINTAINERS
+++ b/MAINTAINERS
@@ -569,7 +569,7 @@
Michael Ploujnikov <michael.ploujnikov@oracle.com>
Paul Pluzhnikov <ppluzhnikov@google.com>
Antoniu Pop <antoniu.pop@gmail.com>
-Siddhesh Poyarekar <siddhesh@sourceware.org>
+Siddhesh Poyarekar <siddhesh@gotplt.org>
Vidya Praveen <vidyapraveen@arm.com>
Thomas Preud'homme <thomas.preudhomme@celest.fr>
Vladimir Prus <vladimir@codesourcery.com>
@@ -708,6 +708,8 @@
Matthias Kretz <m.kretz@gsi.de>
Jeff Law <jeffreyalaw@gmail.com>
Jeff Law <jlaw@tachyum.com>
+ Jonathan Wakely <jwakely@redhat.com>
Gaius Mulley <gaius.mulley@southwales.ac.uk>
+ Siddhesh Poyarekar <siddhesh@gotplt.org>
Trevor Saunders <tbsaunde+gcc@tbsaunde.org>
Petter Tomner <tomner@kth.se>
diff --git a/Makefile.def b/Makefile.def
index 1bed8c1..e015a7a 100644
--- a/Makefile.def
+++ b/Makefile.def
@@ -471,6 +471,14 @@
dependencies = { module=install-binutils; on=install-opcodes; };
dependencies = { module=install-strip-binutils; on=install-strip-opcodes; };
+// Likewise for ld, libctf, and bfd.
+dependencies = { module=install-libctf; on=install-bfd; };
+dependencies = { module=install-ld; on=install-bfd; };
+dependencies = { module=install-ld; on=install-libctf; };
+dependencies = { module=install-strip-libctf; on=install-strip-bfd; };
+dependencies = { module=install-strip-ld; on=install-strip-bfd; };
+dependencies = { module=install-strip-ld; on=install-strip-libctf; };
+
// libopcodes depends on libbfd
dependencies = { module=install-opcodes; on=install-bfd; };
dependencies = { module=install-strip-opcodes; on=install-strip-bfd; };
@@ -564,6 +572,12 @@
dependencies = { module=configure-libctf; on=all-libiconv; };
dependencies = { module=check-libctf; on=all-ld; };
+// The Makefiles in gdb and gdbserver pull in a file that configure
+// generates in the gnulib directory, so distclean gnulib only after
+// gdb and gdbserver.
+dependencies = { module=distclean-gnulib; on=distclean-gdb; };
+dependencies = { module=distclean-gnulib; on=distclean-gdbserver; };
+
// Warning, these are not well tested.
dependencies = { module=all-bison; on=all-intl; };
dependencies = { module=all-bison; on=all-build-texinfo; };
diff --git a/Makefile.in b/Makefile.in
index dd63afc..9219ebf 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -60771,6 +60771,12 @@
all-stageautofeedback-ld: maybe-all-stageautofeedback-libctf
install-binutils: maybe-install-opcodes
install-strip-binutils: maybe-install-strip-opcodes
+install-libctf: maybe-install-bfd
+install-ld: maybe-install-bfd
+install-ld: maybe-install-libctf
+install-strip-libctf: maybe-install-strip-bfd
+install-strip-ld: maybe-install-strip-bfd
+install-strip-ld: maybe-install-strip-libctf
install-opcodes: maybe-install-bfd
install-strip-opcodes: maybe-install-strip-bfd
configure-gas: maybe-configure-intl
@@ -61139,6 +61145,8 @@
check-stagefeedback-libctf: maybe-all-stagefeedback-ld
check-stageautoprofile-libctf: maybe-all-stageautoprofile-ld
check-stageautofeedback-libctf: maybe-all-stageautofeedback-ld
+distclean-gnulib: maybe-distclean-gdb
+distclean-gnulib: maybe-distclean-gdbserver
all-bison: maybe-all-build-texinfo
all-flex: maybe-all-build-bison
all-flex: maybe-all-m4
diff --git a/configure b/configure
index 85ab991..785498e 100755
--- a/configure
+++ b/configure
@@ -8874,6 +8874,16 @@
;;
esac
+# If gcc/ is not in the source tree then we'll not be building a
+# target compiler, assume in that case we don't want to build any
+# target libraries or tools.
+#
+# This was added primarily for the benefit for binutils-gdb who reuse
+# this configure script, but don't always have target tools available.
+if test ! -d ${srcdir}/gcc; then
+ skipdirs="${skipdirs} ${target_configdirs}"
+fi
+
# Remove the entries in $skipdirs and $noconfigdirs from $configdirs,
# $build_configdirs and $target_configdirs.
# If we have the source for $noconfigdirs entries, add them to $notsupp.
diff --git a/configure.ac b/configure.ac
index 1df038b..c523083 100644
--- a/configure.ac
+++ b/configure.ac
@@ -2272,6 +2272,16 @@
;;
esac
+# If gcc/ is not in the source tree then we'll not be building a
+# target compiler, assume in that case we don't want to build any
+# target libraries or tools.
+#
+# This was added primarily for the benefit for binutils-gdb who reuse
+# this configure script, but don't always have target tools available.
+if test ! -d ${srcdir}/gcc; then
+ skipdirs="${skipdirs} ${target_configdirs}"
+fi
+
# Remove the entries in $skipdirs and $noconfigdirs from $configdirs,
# $build_configdirs and $target_configdirs.
# If we have the source for $noconfigdirs entries, add them to $notsupp.
diff --git a/contrib/ChangeLog b/contrib/ChangeLog
index 6521f96..156a61b 100644
--- a/contrib/ChangeLog
+++ b/contrib/ChangeLog
@@ -1,3 +1,8 @@
+2021-10-02 Martin Liska <mliska@suse.cz>
+
+ * filter-clang-warnings.py: Filter out -Wtautological-compare
+ for the file.
+
2021-09-20 Richard Biener <rguenther@suse.de>
* config-list.mk: --enable-obsolete for hppa2.0-hpux10.1 and
diff --git a/contrib/filter-clang-warnings.py b/contrib/filter-clang-warnings.py
index 72b5bbe..361a5c6 100755
--- a/contrib/filter-clang-warnings.py
+++ b/contrib/filter-clang-warnings.py
@@ -47,6 +47,7 @@
'i386.md': ['-Wparentheses-equality', '-Wtautological-compare',
'-Wtautological-overlap-compare'],
'sse.md': ['-Wparentheses-equality', '-Wtautological-compare'],
+ 'mmx.md': ['-Wtautological-compare'],
'genautomata.c': ['-Wstring-plus-int'],
'gfortran.texi': [''],
'libtool': ['']
diff --git a/gcc/ChangeLog b/gcc/ChangeLog
index acbbb71..f9b93b2 100644
--- a/gcc/ChangeLog
+++ b/gcc/ChangeLog
@@ -1,3 +1,1359 @@
+2021-10-06 Andrew MacLeod <amacleod@redhat.com>
+
+ * gimple-range-cache.cc (non_null_ref::adjust_range): Call new
+ intersect routine.
+ * gimple-range-fold.cc (adjust_pointer_diff_expr): Ditto.
+ (adjust_imagpart_expr): Ditto.
+ * value-range.cc (irange::irange_intersect): Call new routine if
+ RHS is a single pair.
+ (irange::intersect): New wide_int version.
+ * value-range.h (class irange): New prototype.
+
+2021-10-06 Andrew MacLeod <amacleod@redhat.com>
+
+ * gimple-range-edge.cc (gimple_outgoing_range::gimple_outgoing_range):
+ Add parameter to limit size when recognizing switches.
+ (gimple_outgoing_range::edge_range_p): Check size limit.
+ * gimple-range-edge.h (gimple_outgoing_range): Add size field.
+ * gimple-range-gori.cc (gori_map::calculate_gori): Ignore switches
+ that exceed the size limit.
+ (gori_compute::gori_compute): Add initializer.
+ * params.opt (evrp-switch-limit): New.
+ * doc/invoke.texi: Update docs.
+
+2021-10-06 Andrew MacLeod <amacleod@redhat.com>
+
+ * value-range.h (irange::set_varying): Use TYPE_MIN_VALUE and
+ TYPE_MAX_VALUE instead of creating new trees when possible.
+
+2021-10-06 Andrew MacLeod <amacleod@redhat.com>
+
+ * gimple-range-cache.cc (non_null_ref::adjust_range): Check for
+ zero and non-zero more efficently.
+
+2021-10-06 Richard Biener <rguenther@suse.de>
+
+ PR c/102605
+ * dumpfile.h (TDF_GIMPLE_VAL): New.
+ (dump_flag): Re-order and adjust TDF_* flags. Make
+ the enum uint32_t. Use std::underlying_type in the
+ operator overloads.
+ (optgroup_flag): Likewise for the operator overloads.
+ * tree-pretty-print.c (dump_generic_node): Wrap ADDR_EXPR
+ in _Literal if TDF_GIMPLE_VAL.
+ * gimple-pretty-print.c (dump_gimple_assign): Add
+ TDF_GIMPLE_VAL to flags when dumping operands where only
+ is_gimple_val are allowed.
+ (dump_gimple_cond): Likewise.
+
+2021-10-06 prathamesh.kulkarni <prathamesh.kulkarni@linaro.org>
+
+ * gimple-isel.cc (gimple_expand_vec_cond_expr): Remove redundant if
+ condition.
+
+2021-10-05 qing zhao <qing.zhao@oracle.com>
+
+ PR middle-end/102359
+ * gimplify.c (gimplify_decl_expr): Not add initialization for an
+ auto variable when it has been initialized by frontend.
+
+2021-10-05 Aldy Hernandez <aldyh@redhat.com>
+
+ * tree-ssa-threadupdate.c (jt_path_registry::cancel_invalid_paths):
+ Loosen restrictions
+
+2021-10-05 Jan-Benedict Glaw <jbglaw@lug-owl.de>
+
+ * common/config/avr/avr-common.c (avr_handle_option): Mark
+ argument as ATTRIBUTE_UNUSED.
+
+2021-10-05 Jan-Benedict Glaw <jbglaw@lug-owl.de>
+
+ * config/lm32/uclinux-elf.h (LINK_GCC_C_SEQUENCE_SPEC):
+ Undefine before redefinition.
+
+2021-10-05 Richard Biener <rguenther@suse.de>
+
+ * toplev.c (no_backend): Remove global var.
+ (process_options): Pass in no_backend, move post_options
+ langhook call to toplev::main.
+ (do_compile): Pass in no_backend, move process_options call
+ to toplev::main.
+ (toplev::run_self_tests): Check no_backend at the caller.
+ (toplev::main): Call post_options and process_options
+ split out from do_compile, do self-tests only if
+ no_backend is initialized.
+
+2021-10-05 Richard Biener <rguenther@suse.de>
+
+ * tree-cfg.c (dump_function_to_file): Dump the UID of the
+ function as part of the name when requested.
+ * tree-pretty-print.c (dump_function_name): Dump the UID when
+ requested and the langhook produced the actual name.
+
+2021-10-05 Richard Biener <rguenther@suse.de>
+
+ PR middle-end/102587
+ PR middle-end/102285
+ * internal-fn.c (expand_DEFERRED_INIT): Fall back to
+ zero-initialization as last resort, use the constant
+ size as given by the DEFERRED_INIT argument to build
+ the initializer.
+
+2021-10-04 Marek Polacek <polacek@redhat.com>
+
+ PR c++/97573
+ * doc/invoke.texi: Document -Warray-compare.
+
+2021-10-04 Richard Biener <rguenther@suse.de>
+
+ * gimplify.c (is_var_need_auto_init): DECL_HARD_REGISTER
+ variables are not to be initialized.
+
+2021-10-04 Richard Biener <rguenther@suse.de>
+
+ * expr.h (non_mem_decl_p): Declare.
+ (mem_ref_refers_to_non_mem_p): Likewise.
+ * expr.c (non_mem_decl_p): Export.
+ (mem_ref_refers_to_non_mem_p): Likewise.
+ * internal-fn.c (expand_DEFERRED_INIT): Do not expand the LHS
+ but check the base with mem_ref_refers_to_non_mem_p
+ and non_mem_decl_p.
+
+2021-10-04 Richard Biener <rguenther@suse.de>
+
+ PR tree-optimization/102570
+ * tree-ssa-sccvn.h (vn_reference_op_struct): Document
+ we are using clique for the internal function code.
+ * tree-ssa-sccvn.c (vn_reference_op_eq): Compare the
+ internal function code.
+ (print_vn_reference_ops): Print the internal function code.
+ (vn_reference_op_compute_hash): Hash it.
+ (copy_reference_ops_from_call): Record it.
+ (visit_stmt): Remove the restriction around internal function
+ calls.
+ (fully_constant_vn_reference_p): Use fold_const_call and handle
+ internal functions.
+ (vn_reference_eq): Compare call return types.
+ * tree-ssa-pre.c (create_expression_by_pieces): Handle
+ generating calls to internal functions.
+ (compute_avail): Remove the restriction around internal function
+ calls.
+
+2021-10-04 Aldy Hernandez <aldyh@redhat.com>
+
+ PR tree-optimization/102560
+ * gimple-ssa-warn-alloca.c (alloca_call_type): Remove static
+ marker for invalid_range.
+
+2021-10-04 Richard Biener <rguenther@suse.de>
+
+ PR middle-end/102587
+ * internal-fn.c (expand_DEFERRED_INIT): Guard register
+ initialization path an avoid initializing VLA registers
+ with it.
+
+2021-10-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * config/rs6000/vxworks.h (TARGET_INIT_LIBFUNCS): Delete.
+
+2021-10-03 Martin Liska <mliska@suse.cz>
+
+ * toplev.c (toplev::main): Check opt_index if it is a part
+ of cl_options.
+
+2021-10-02 Aldy Hernandez <aldyh@redhat.com>
+
+ PR tree-optimization/102563
+ * range-op.cc (operator_lshift::op1_range): Do not clobber
+ range.
+
+2021-10-02 Martin Liska <mliska@suse.cz>
+
+ * toplev.c (toplev::main): save_decoded_options[0] is program
+ name and so it should be skipped.
+
+2021-10-01 Aldy Hernandez <aldyh@redhat.com>
+
+ PR tree-optimization/102546
+ * range-op.cc (operator_lshift::op1_range): Teach range-ops that
+ X << Y is non-zero implies X is also non-zero.
+
+2021-10-01 Przemyslaw Wirkus <przemyslaw.wirkus@arm.com>
+
+ * config/aarch64/aarch64-cores.def (AARCH64_CORE): New
+ Cortex-X2 core.
+ * config/aarch64/aarch64-tune.md: Regenerate.
+ * doc/invoke.texi: Update docs.
+
+2021-10-01 Przemyslaw Wirkus <przemyslaw.wirkus@arm.com>
+
+ * config/aarch64/aarch64-cores.def (AARCH64_CORE): New
+ Cortex-A710 core.
+ * config/aarch64/aarch64-tune.md: Regenerate.
+ * doc/invoke.texi: Update docs.
+
+2021-10-01 Przemyslaw Wirkus <przemyslaw.wirkus@arm.com>
+
+ * config/aarch64/aarch64-cores.def (AARCH64_CORE): New
+ Cortex-A510 core.
+ * config/aarch64/aarch64-tune.md: Regenerate.
+ * doc/invoke.texi: Update docs.
+
+2021-10-01 Martin Sebor <msebor@redhat.com>
+
+ PR c/102103
+ * doc/invoke.texi (-Waddress): Update.
+ * gengtype.c (write_types): Avoid -Waddress.
+ * poly-int.h (POLY_SET_COEFF): Avoid using null.
+
+2021-10-01 John David Anglin <danglin@gcc.gnu.org>
+
+ PR debug/102373
+ * config/pa/pa.c (pa_option_override): Default to dwarf version 4
+ on hppa64-hpux.
+
+2021-10-01 Przemyslaw Wirkus <przemyslaw.wirkus@arm.com>
+
+ * config/aarch64/aarch64.h (AARCH64_FL_V9): Update value.
+
+2021-10-01 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc (path_range_query::compute_ranges): Use
+ get_path_oracle.
+ * gimple-range-path.h (class path_range_query): Remove shadowed
+ m_oracle field.
+ (path_range_query::get_path_oracle): New.
+
+2021-10-01 Jakub Jelinek <jakub@redhat.com>
+ Richard Biener <rguenther@suse.de>
+
+ PR sanitizer/102515
+ * doc/invoke.texi (-fsanitize=integer-divide-by-zero): Remove
+ INT_MIN / -1 division detection from here ...
+ (-fsanitize=signed-integer-overflow): ... and add it here.
+
+2021-10-01 Przemyslaw Wirkus <przemyslaw.wirkus@arm.com>
+
+ * config/aarch64/aarch64-arches.def (AARCH64_ARCH): Added
+ armv9-a.
+ * config/aarch64/aarch64.h (AARCH64_FL_V9): New.
+ (AARCH64_FL_FOR_ARCH9): New flags for Armv9-A.
+ (AARCH64_ISA_V9): New ISA flag.
+ * doc/invoke.texi: Update docs.
+
+2021-10-01 Martin Liska <mliska@suse.cz>
+
+ * toplev.c (toplev::main): Save decoded optimization options.
+ * toplev.h (save_opt_decoded_options): New.
+ * doc/extend.texi: Be more clear about optimize and target
+ attributes.
+
+2021-10-01 Eric Botcazou <ebotcazou@adacore.com>
+
+ * explow.c: Include langhooks.h.
+ (set_stack_check_libfunc): Build a proper function type.
+
+2021-10-01 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR c++/64697
+ * config/i386/i386.c (legitimate_pic_address_disp_p): For PE-COFF do
+ not return true for external weak function symbols in medium model.
+
+2021-10-01 Jakub Jelinek <jakub@redhat.com>
+
+ * tree.h (OMP_CLAUSE_ORDER_REPRODUCIBLE): Define.
+ * tree-pretty-print.c (dump_omp_clause) <case OMP_CLAUSE_ORDER>: Print
+ reproducible: for OMP_CLAUSE_ORDER_REPRODUCIBLE.
+ * omp-general.c (omp_extract_for_data): If OMP_CLAUSE_ORDER is seen
+ without OMP_CLAUSE_ORDER_UNCONSTRAINED, overwrite sched_kind to
+ OMP_CLAUSE_SCHEDULE_STATIC.
+
+2021-10-01 Richard Biener <rguenther@suse.de>
+
+ PR middle-end/102518
+ * tree-inline.c (setup_one_parameter): Avoid substituting
+ an invariant into contexts where a GIMPLE register is not valid.
+
+2021-09-30 Przemyslaw Wirkus <przemyslaw.wirkus@arm.com>
+
+ * config/arm/arm-cpus.in: Add Cortex-R52+ CPU.
+ * config/arm/arm-tables.opt: Regenerate.
+ * config/arm/arm-tune.md: Regenerate.
+ * doc/invoke.texi: Update docs.
+
+2021-09-30 Uroš Bizjak <ubizjak@gmail.com>
+
+ PR target/89954
+ * config/i386/i386.md
+ (sign_extend:WIDE (any_logic:NARROW (memory, immediate)) splitters):
+ New splitters.
+
+2021-09-30 Tobias Burnus <tobias@codesourcery.com>
+
+ * omp-low.c (omp_runtime_api_call): Add omp_aligned_{,c}alloc and
+ omp_{c,re}alloc, fix omp_alloc/omp_free.
+
+2021-09-30 Martin Liska <mliska@suse.cz>
+
+ * defaults.h (ASM_OUTPUT_ASCII): Do not hide global variable
+ asm_out_file and stream directly to MYFILE.
+
+2021-09-30 Richard Biener <rguenther@suse.de>
+
+ * tree-vect-data-refs.c (vect_update_misalignment_for_peel):
+ Restore and fix condition under which we apply npeel to
+ the DRs misalignment value.
+
+2021-09-30 Richard Biener <rguenther@suse.de>
+
+ * tree-vect-data-refs.c (vect_update_misalignment_for_peel):
+ Fix npeel check for variable amount of peeling.
+
+2021-09-30 Aldy Hernandez <aldyh@redhat.com>
+
+ * lto-wrapper.c (run_gcc): Plug snprintf overflow.
+
+2021-09-30 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range.cc (gimple_ranger::debug): New.
+ * gimple-range.h (class gimple_ranger): Add debug.
+
+2021-09-30 Aldy Hernandez <aldyh@redhat.com>
+
+ PR middle-end/102519
+ * tree-vrp.c (hybrid_threader::~hybrid_threader): Free m_query.
+
+2021-09-29 Indu Bhagat <indu.bhagat@oracle.com>
+
+ PR debug/102507
+ * btfout.c (GTY): Add GTY (()) albeit for cosmetic only purpose.
+ (btf_finalize): Empty the hash_map btf_var_ids.
+
+2021-09-29 Aldy Hernandez <aldyh@redhat.com>
+
+ * tree-vrp.c (thread_through_all_blocks): Return bool.
+ (execute_vrp_threader): Return TODO_* flags.
+ (pass_data_vrp_threader): Set todo_flags_finish to 0.
+
+2021-09-29 Aldy Hernandez <aldyh@redhat.com>
+
+ * timevar.def (TV_TREE_VRP_THREADER): New.
+ * tree-vrp.c: Use TV_TREE_VRP_THREADER for VRP threader pass.
+
+2021-09-29 David Faust <david.faust@oracle.com>
+
+ * config.gcc (bpf-*-*): Do not overwrite extra_headers.
+
+2021-09-29 Jonathan Wright <jonathan.wright@arm.com>
+
+ * config/aarch64/aarch64-builtins.c (TYPES_BINOP_PPU): Define
+ new type qualifier enum.
+ (TYPES_TERNOP_SSSU): Likewise.
+ (TYPES_TERNOP_PPPU): Likewise.
+ * config/aarch64/aarch64-simd-builtins.def: Define PPU, SSU,
+ PPPU and SSSU builtin generator macros for qtbl1 and qtbx1
+ Neon builtins.
+ * config/aarch64/arm_neon.h (vqtbl1_p8): Use type-qualified
+ builtin and remove casts.
+ (vqtbl1_s8): Likewise.
+ (vqtbl1q_p8): Likewise.
+ (vqtbl1q_s8): Likewise.
+ (vqtbx1_s8): Likewise.
+ (vqtbx1_p8): Likewise.
+ (vqtbx1q_s8): Likewise.
+ (vqtbx1q_p8): Likewise.
+ (vtbl1_p8): Likewise.
+ (vtbl2_p8): Likewise.
+ (vtbx2_p8): Likewise.
+
+2021-09-29 Richard Biener <rguenther@suse.de>
+
+ * tree-vect-data-refs.c (vect_dr_misalign_for_aligned_access):
+ New helper.
+ (vect_update_misalignment_for_peel): Use it to update
+ misaligned to the value necessary for an aligned access.
+ (vect_get_peeling_costs_all_drs): Likewise.
+ (vect_enhance_data_refs_alignment): Likewise.
+
+2021-09-29 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
+
+ * config/aarch64/aarch64.c (aarch64_expand_cpymem): Count number of
+ emitted operations and adjust heuristic for code size.
+
+2021-09-29 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
+
+ * config/aarch64/aarch64.c (aarch64_expand_setmem): Count number of
+ emitted operations and adjust heuristic for code size.
+
+2021-09-29 Jakub Jelinek <jakub@redhat.com>
+
+ PR middle-end/102504
+ * gimplify.c (gimplify_scan_omp_clauses): Use omp_check_private even
+ in OMP_SCOPE clauses, not just on worksharing construct clauses.
+
+2021-09-28 Geng Qi <gengqi@linux.alibaba.com>
+
+ * config/riscv/riscv.md (mulv<mode>4): Call gen_smul<mode>3_highpart.
+ (<u>mulditi3): Call <su>muldi3_highpart.
+ (<u>muldi3_highpart): Rename to <su>muldi3_highpart.
+ (<u>mulsidi3): Call <su>mulsi3_highpart.
+ (<u>mulsi3_highpart): Rename to <su>mulsi3_highpart.
+
+2021-09-28 Iain Sandoe <iain@sandoe.co.uk>
+
+ * config/darwin.h (DSYMUTIL_SPEC): Recognize D sources.
+
+2021-09-28 Iain Sandoe <iain@sandoe.co.uk>
+
+ * config/rs6000/darwin.h (FIXED_R13): Add for PPC64.
+ (FIRST_SAVED_GP_REGNO): Save from R13 even when it is one
+ of the fixed regs.
+
+2021-09-28 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
+
+ * config/aarch64/aarch64.h (AARCH64_FL_LS64): Define
+ (AARCH64_FL_V8_7): Likewise.
+ (AARCH64_FL_FOR_ARCH8_7): Likewise.
+ * config/aarch64/aarch64-arches.def (armv8.7-a): Define.
+ * config/aarch64/aarch64-option-extensions.def (ls64): Define.
+ * doc/invoke.texi: Document the above.
+
+2021-09-28 Aldy Hernandez <aldyh@redhat.com>
+
+ * dbgcnt.c (dbg_cnt_counter): New.
+ * dbgcnt.h (dbg_cnt_counter): New.
+ * dumpfile.c (dump_options): Add entry for TDF_THREADING.
+ * dumpfile.h (enum dump_flag): Add TDF_THREADING.
+ * gimple-range-path.cc (DEBUG_SOLVER): Use TDF_THREADING.
+ * tree-ssa-threadupdate.c (dump_jump_thread_path): Dump out
+ debug counter.
+
+2021-09-28 Aldy Hernandez <aldyh@redhat.com>
+
+ * cfgcleanup.c (pass_jump::execute): Check
+ flag_expensive_optimizations.
+ (pass_jump_after_combine::gate): Same.
+ * doc/invoke.texi (-fthread-jumps): Enable for -O1.
+ * opts.c (default_options_table): Enable -fthread-jumps at -O1.
+ * tree-ssa-threadupdate.c
+ (fwd_jt_path_registry::remove_jump_threads_including): Bail unless
+ flag_thread_jumps.
+
+2021-09-28 Ilya Leoshkevich <iii@linux.ibm.com>
+
+ * tree-ssa-reassoc.c (biased_names): New global.
+ (propagate_bias_p): New function.
+ (loop_carried_phi): Remove.
+ (propagate_rank): Propagate bias along single uses.
+ (get_rank): Update biased_names when needed.
+
+2021-09-28 Ilya Leoshkevich <iii@linux.ibm.com>
+
+ * passes.def (pass_reassoc): Rename parameter to early_p.
+ * tree-ssa-reassoc.c (reassoc_bias_loop_carried_phi_ranks_p):
+ New variable.
+ (phi_rank): Don't bias loop-carried phi ranks
+ before vectorization pass.
+ (execute_reassoc): Add bias_loop_carried_phi_ranks_p parameter.
+ (pass_reassoc::pass_reassoc): Add bias_loop_carried_phi_ranks_p
+ initializer.
+ (pass_reassoc::set_param): Set bias_loop_carried_phi_ranks_p
+ value.
+ (pass_reassoc::execute): Pass bias_loop_carried_phi_ranks_p to
+ execute_reassoc.
+ (pass_reassoc::bias_loop_carried_phi_ranks_p): New member.
+
+2021-09-28 Jakub Jelinek <jakub@redhat.com>
+
+ PR target/102498
+ * config/i386/i386.c (standard_80387_constant_p): Don't recognize
+ special 80387 instruction XFmode constants if flag_rounding_math.
+
+2021-09-28 Richard Biener <rguenther@suse.de>
+
+ PR tree-optimization/100112
+ * tree-ssa-sccvn.c (visit_reference_op_load): Record the
+ referece into the hashtable twice in case last_vuse is
+ different from the original vuse on the stmt.
+
+2021-09-28 Jakub Jelinek <jakub@redhat.com>
+
+ PR middle-end/102492
+ * gimplify.c (gimplify_adjust_omp_clauses_1): Don't call the
+ omp_finish_clause langhook on implicitly added OMP_CLAUSE_PRIVATE
+ clauses on SIMD constructs.
+
+2021-09-28 Aldy Hernandez <aldyh@redhat.com>
+
+ PR tree-optimization/102511
+ * gimple-range-path.cc (path_range_query::range_on_path_entry):
+ Return VARYING when nothing found.
+
+2021-09-28 Hongyu Wang <hongyu.wang@intel.com>
+
+ PR target/102230
+ * config/i386/i386.h (VALID_AVX512FP16_REG_MODE): Add
+ V2HF mode check.
+ (VALID_SSE2_REG_VHF_MODE): Add V4HFmode and V2HFmode.
+ (VALID_MMX_REG_MODE): Add V4HFmode.
+ (SSE_REG_MODE_P): Replace VALID_AVX512FP16_REG_MODE with
+ vector mode condition.
+ * config/i386/i386.c (classify_argument): Parse V4HF/V2HF
+ via sse regs.
+ (function_arg_32): Add V4HFmode.
+ (function_arg_advance_32): Likewise.
+ * config/i386/i386.md (mode): Add V4HF/V2HF.
+ (MODE_SIZE): Likewise.
+ * config/i386/mmx.md (MMXMODE): Add V4HF mode.
+ (V_32): Add V2HF mode.
+ (VHF_32_64): New mode iterator.
+ (*mov<mode>_internal): Adjust sse alternatives to support
+ V4HF mode move.
+ (*mov<mode>_internal): Adjust sse alternatives to support
+ V2HF mode move.
+ (<insn><mode>3): New define_insn for add/sub/mul/div.
+
+2021-09-28 Aldy Hernandez <aldyh@redhat.com>
+
+ * tree-ssa-threadbackward.c (pass_thread_jumps::gate): Check
+ flag_thread_jumps.
+ (pass_early_thread_jumps::gate): Same.
+ * tree-ssa-threadedge.c (jump_threader::thread_outgoing_edges):
+ Return if !flag_thread_jumps.
+ * tree-ssa-threadupdate.c
+ (jt_path_registry::register_jump_thread): Assert that
+ flag_thread_jumps is true.
+
+2021-09-28 liuhongt <hongtao.liu@intel.com>
+
+ * simplify-rtx.c
+ (simplify_context::simplify_binary_operation_1): Relax
+ condition of simplifying (vec_concat:M (vec_select op0
+ index0)(vec_select op1 index1)) to allow different modes
+ between op0 and M, but have same inner mode.
+
+2021-09-28 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/i386-expand.c (emit_reduc_half): Handle
+ V8HF/V16HF/V32HFmode.
+ * config/i386/sse.md (REDUC_SSE_PLUS_MODE): Add V8HF.
+ (REDUC_SSE_SMINMAX_MODE): Ditto.
+ (REDUC_PLUS_MODE): Add V16HF and V32HF.
+ (REDUC_SMINMAX_MODE): Ditto.
+
+2021-09-27 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc
+ (path_range_query::precompute_ranges_in_block): Rename to...
+ (path_range_query::compute_ranges_in_block): ...this.
+ (path_range_query::precompute_ranges): Rename to...
+ (path_range_query::compute_ranges): ...this.
+ (path_range_query::precompute_relations): Rename to...
+ (path_range_query::compute_relations): ...this.
+ (path_range_query::precompute_phi_relations): Rename to...
+ (path_range_query::compute_phi_relations): ...this.
+ * gimple-range-path.h: Rename precompute* to compute*.
+ * tree-ssa-threadbackward.c
+ (back_threader::find_taken_edge_switch): Same.
+ (back_threader::find_taken_edge_cond): Same.
+ * tree-ssa-threadedge.c
+ (hybrid_jt_simplifier::compute_ranges_from_state): Same.
+ (hybrid_jt_state::register_equivs_stmt): Inline...
+ * tree-ssa-threadedge.h: ...here.
+
+2021-09-27 Aldy Hernandez <aldyh@redhat.com>
+
+ * tree-vrp.c (lhs_of_dominating_assert): Remove.
+ (class vrp_jt_state): Remove.
+ (class vrp_jt_simplifier): Remove.
+ (vrp_jt_simplifier::simplify): Remove.
+ (class vrp_jump_threader): Remove.
+ (vrp_jump_threader::vrp_jump_threader): Remove.
+ (vrp_jump_threader::~vrp_jump_threader): Remove.
+ (vrp_jump_threader::before_dom_children): Remove.
+ (vrp_jump_threader::after_dom_children): Remove.
+
+2021-09-27 Aldy Hernandez <aldyh@redhat.com>
+
+ * passes.def (pass_vrp_threader): New.
+ * tree-pass.h (make_pass_vrp_threader): Add make_pass_vrp_threader.
+ * tree-ssa-threadedge.c (hybrid_jt_state::register_equivs_stmt): New.
+ (hybrid_jt_simplifier::hybrid_jt_simplifier): New.
+ (hybrid_jt_simplifier::simplify): New.
+ (hybrid_jt_simplifier::compute_ranges_from_state): New.
+ * tree-ssa-threadedge.h (class hybrid_jt_state): New.
+ (class hybrid_jt_simplifier): New.
+ * tree-vrp.c (execute_vrp): Remove ASSERT_EXPR based jump
+ threader.
+ (class hybrid_threader): New.
+ (hybrid_threader::hybrid_threader): New.
+ (hybrid_threader::~hybrid_threader): New.
+ (hybrid_threader::before_dom_children): New.
+ (hybrid_threader::after_dom_children): New.
+ (execute_vrp_threader): New.
+ (class pass_vrp_threader): New.
+ (make_pass_vrp_threader): New.
+
+2021-09-27 Martin Liska <mliska@suse.cz>
+
+ * output.h (enum section_flag): New.
+ (SECTION_FORGET): Remove.
+ (SECTION_ENTSIZE): Make it (1UL << 8) - 1.
+ (SECTION_STYLE_MASK): Define it based on other enum
+ values.
+ * varasm.c (switch_to_section): Remove unused handling of
+ SECTION_FORGET.
+
+2021-09-27 Martin Liska <mliska@suse.cz>
+
+ * common.opt: Add new variable flag_default_complex_method.
+ * opts.c (finish_options): Handle flags related to
+ x_flag_complex_method.
+ * toplev.c (process_options): Remove option handling related
+ to flag_complex_method.
+
+2021-09-27 Richard Biener <rguenther@suse.de>
+
+ PR middle-end/102450
+ * gimple-fold.c (gimple_fold_builtin_memory_op): Avoid using
+ type_for_size, instead use int_mode_for_size.
+
+2021-09-27 Andrew Pinski <apinski@marvell.com>
+
+ PR c/94726
+ * gimplify.c (gimplify_save_expr): Return early
+ if the type of val is error_mark_node.
+
+2021-09-27 Aldy Hernandez <aldyh@redhat.com>
+
+ * tree-ssanames.c (ssa_name_has_boolean_range): Use
+ get_range_query.
+
+2021-09-27 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-ssa-evrp-analyze.h (class evrp_range_analyzer): Remove
+ vrp_visit_cond_stmt.
+ * tree-ssa-dom.c (cprop_operand): Convert to range_query API.
+ (cprop_into_stmt): Same.
+ (dom_opt_dom_walker::optimize_stmt): Same.
+
+2021-09-27 Richard Biener <rguenther@suse.de>
+
+ PR tree-optimization/97351
+ PR tree-optimization/97352
+ PR tree-optimization/82426
+ * tree-vectorizer.h (dr_misalignment): Add vector type
+ argument.
+ (aligned_access_p): Likewise.
+ (known_alignment_for_access_p): Likewise.
+ (vect_supportable_dr_alignment): Likewise.
+ (vect_known_alignment_in_bytes): Likewise. Refactor.
+ (DR_MISALIGNMENT): Remove.
+ (vect_update_shared_vectype): Likewise.
+ * tree-vect-data-refs.c (dr_misalignment): Refactor, handle
+ a vector type with larger alignment requirement and apply
+ the negative step adjustment here.
+ (vect_calculate_target_alignment): Remove.
+ (vect_compute_data_ref_alignment): Get explicit vector type
+ argument, do not apply a negative step alignment adjustment
+ here.
+ (vect_slp_analyze_node_alignment): Re-analyze alignment
+ when we re-visit the DR with a bigger desired alignment but
+ keep more precise results from smaller alignments.
+ * tree-vect-slp.c (vect_update_shared_vectype): Remove.
+ (vect_slp_analyze_node_operations_1): Do not update the
+ shared vector type on stmts.
+ * tree-vect-stmts.c (vect_analyze_stmt): Push/pop the
+ vector type of an SLP node to the representative stmt-info.
+ (vect_transform_stmt): Likewise.
+
+2021-09-27 liuhongt <hongtao.liu@intel.com>
+
+ Revert:
+ 2021-09-09 liuhongt <hongtao.liu@intel.com>
+
+ PR target/101059
+ * config/i386/sse.md (reduc_plus_scal_<mode>): Split to ..
+ (reduc_plus_scal_v4sf): .. this, New define_expand.
+ (reduc_plus_scal_v2df): .. and this, New define_expand.
+
+2021-09-26 liuhongt <hongtao.liu@intel.com>
+
+ * doc/extend.texi (Half-Precision): Remove storage only
+ description for _Float16 w/o avx512fp16.
+
+2021-09-25 Dimitar Dimitrov <dimitar@dinux.eu>
+
+ * config/pru/constraints.md (Rrio): New constraint.
+ * config/pru/predicates.md (regio_operand): New predicate.
+ * config/pru/pru-pragma.c (pru_register_pragmas): Register
+ the __regio_symbol address space.
+ * config/pru/pru-protos.h (pru_symref2ioregno): Declaration.
+ * config/pru/pru.c (pru_symref2ioregno): New helper function.
+ (pru_legitimate_address_p): Remove.
+ (pru_addr_space_legitimate_address_p): Use the address space
+ aware hook variant.
+ (pru_nongeneric_pointer_addrspace): New helper function.
+ (pru_insert_attributes): New function to validate __regio_symbol
+ usage.
+ (TARGET_INSERT_ATTRIBUTES): New macro.
+ (TARGET_LEGITIMATE_ADDRESS_P): Remove.
+ (TARGET_ADDR_SPACE_LEGITIMATE_ADDRESS_P): New macro.
+ * config/pru/pru.h (enum reg_class): Add REGIO_REGS class.
+ * config/pru/pru.md (*regio_readsi): New pattern to read I/O
+ registers.
+ (*regio_nozext_writesi): New pattern to write to I/O registers.
+ (*regio_zext_write_r30<EQS0:mode>): Ditto.
+ * doc/extend.texi: Document the new PRU Named Address Space.
+
+2021-09-24 Patrick Palka <ppalka@redhat.com>
+
+ PR c++/98216
+ PR c++/91292
+ * real.c (encode_ieee_double): Avoid unwanted sign extension.
+ (encode_ieee_quad): Likewise.
+
+2021-09-24 Vladimir Makarov <vmakarov@redhat.com>
+
+ PR rtl-optimization/102147
+ * ira-build.c (ira_conflict_vector_profitable_p): Make
+ profitability calculation independent of host compiler pointer and
+ IRA_INT_BITS sizes.
+
+2021-09-24 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc (path_range_query::path_range_query):
+ Move debugging header...
+ (path_range_query::precompute_ranges): ...here.
+ (path_range_query::internal_range_of_expr): Do not call
+ range_on_path_entry if NAME is defined in the current block.
+
+2021-09-24 Richard Biener <rguenther@suse.de>
+
+ * cfghooks.c (verify_flow_info): Verify unallocated BB and
+ edge flags are not set.
+
+2021-09-24 Aldy Hernandez <aldyh@redhat.com>
+
+ * tree-ssa-threadupdate.c (jt_path_registry::cancel_invalid_paths):
+ New.
+ (jt_path_registry::register_jump_thread): Call
+ cancel_invalid_paths.
+ * tree-ssa-threadupdate.h (class jt_path_registry): Add
+ cancel_invalid_paths.
+
+2021-09-24 Feng Xue <fxue@os.amperecomputing.com>
+
+ PR tree-optimization/102400
+ * tree-ssa-sccvn.c (vn_reference_insert_pieces): Initialize
+ result_vdef to zero value.
+
+2021-09-24 Feng Xue <fxue@os.amperecomputing.com>
+
+ PR tree-optimization/102451
+ * tree-ssa-dse.c (delete_dead_or_redundant_call): Record bb of stmt
+ before removal.
+
+2021-09-24 Hongyu Wang <hongyu.wang@intel.com>
+
+ * config/i386/sse.md (cond_<insn><mode>): Extend to support
+ vector HFmodes.
+ (cond_mul<mode>): Likewise.
+ (cond_div<mode>): Likewise.
+ (cond_<code><mode>): Likewise.
+ (cond_fma<mode>): Likewise.
+ (cond_fms<mode>): Likewise.
+ (cond_fnma<mode>): Likewise.
+ (cond_fnms<mode>): Likewise.
+
+2021-09-23 Andrew MacLeod <amacleod@redhat.com>
+
+ PR tree-optimization/102463
+ * gimple-range-fold.cc (fold_using_range::relation_fold_and_or): If
+ there is no range-ops handler, don't look for a relation.
+
+2021-09-23 Andrew MacLeod <amacleod@redhat.com>
+
+ * gimple-range-cache.cc (ranger_cache::ranger_cache): Take
+ non-executable_edge flag as parameter.
+ * gimple-range-cache.h (ranger_cache): Adjust prototype.
+ * gimple-range-gori.cc (gori_compute::gori_compute): Take
+ non-executable_edge flag as parameter.
+ (gori_compute::outgoing_edge_range_p): Check new flag.
+ * gimple-range-gori.h (gori_compute): Adjust prototype.
+ * gimple-range.cc (gimple_ranger::gimple_ranger): Create new flag.
+ (gimple_ranger::range_on_edge): Check new flag.
+ * gimple-range.h (gimple_ranger::non_executable_edge_flag): New.
+ * gimple-ssa-evrp.c (rvrp_folder): Pass ranger flag to simplifer.
+ (hybrid_folder::hybrid_folder): Set ranger non-executable flag value.
+ (hybrid_folder::fold_stmt): Set flag value in the simplifer.
+ * vr-values.c (simplify_using_ranges::set_and_propagate_unexecutable):
+ Use not_executable flag if provided inmstead of EDGE_EXECUTABLE.
+ (simplify_using_ranges::simplify_switch_using_ranges): Clear
+ EDGE_EXECUTABLE like it originally did.
+ (simplify_using_ranges::cleanup_edges_and_switches): Clear any
+ NON_EXECUTABLE flags.
+ (simplify_using_ranges::simplify_using_ranges): Adjust.
+ * vr-values.h (class simplify_using_ranges): Adjust.
+ (simplify_using_ranges::set_range_query): Add non-executable flag param.
+
+2021-09-23 Bill Schmidt <wschmidt@linux.ibm.com>
+
+ PR target/102024
+ * config/rs6000/rs6000-call.c (rs6000_aggregate_candidate): Detect
+ zero-width bit fields and return indicator.
+ (rs6000_discover_homogeneous_aggregate): Diagnose when the
+ presence of a zero-width bit field changes parameter passing in
+ GCC 12.
+
+2021-09-23 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-fold.cc (fold_using_range::range_of_phi):
+ Remove dominator check.
+
+2021-09-23 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc (path_range_query::precompute_relations):
+ Hoist edge calculations before using EDGE_SUCC.
+
+2021-09-23 Jonathan Wakely <jwakely@redhat.com>
+
+ * configure.ac: Fix --with-multilib-list description.
+ * configure: Regenerate.
+
+2021-09-23 Richard Biener <rguenther@suse.de>
+
+ PR tree-optimization/102448
+ * tree-vect-data-refs.c (vect_duplicate_ssa_name_ptr_info):
+ Clear alignment info copied from DR_PTR_INFO.
+
+2021-09-23 Hongyu Wang <hongyu.wang@intel.com>
+
+ * config/i386/i386-expand.c (ix86_use_mask_cmp_p): Enable
+ HFmode mask_cmp.
+ * config/i386/sse.md (sseintvecmodelower): Add HF vector modes.
+ (<avx512>_store<mode>_mask): Extend to support HF vector modes.
+ (vec_cmp<mode><avx512fmaskmodelower>): Likewise.
+ (vcond_mask_<mode><avx512fmaskmodelower>): Likewise.
+ (vcond<mode><mode>): New expander.
+ (vcond<mode><sseintvecmodelower>): Likewise.
+ (vcond<sseintvecmodelower><mode>): Likewise.
+ (vcondu<mode><sseintvecmodelower>): Likewise.
+
+2021-09-23 Hongyu Wang <hongyu.wang@intel.com>
+
+ * config/i386/sse.md (extend<ssePHmodelower><mode>2):
+ New expander.
+ (extendv4hf<mode>2): Likewise.
+ (extendv2hfv2df2): Likewise.
+ (trunc<mode><ssePHmodelower>2): Likewise.
+ (avx512fp16_vcvt<castmode>2ph_<mode>): Rename to ...
+ (trunc<mode>v4hf2): ... this, and drop constraints.
+ (avx512fp16_vcvtpd2ph_v2df): Rename to ...
+ (truncv2dfv2hf2): ... this, and likewise.
+
+2021-09-23 Hongyu Wang <hongyu.wang@intel.com>
+
+ * config/i386/sse.md (float<floatunssuffix><mode><ssePHmodelower>2):
+ New expander.
+ (avx512fp16_vcvt<floatsuffix><sseintconvert>2ph_<mode>):
+ Rename to ...
+ (float<floatunssuffix><mode>v4hf2): ... this, and drop constraints.
+ (avx512fp16_vcvt<floatsuffix>qq2ph_v2di): Rename to ...
+ (float<floatunssuffix>v2div2hf2): ... this, and likewise.
+
+2021-09-23 Hongyu Wang <hongyu.wang@intel.com>
+
+ * config/i386/i386.md (fix<fixunssuffix>_trunchf<mode>2): New expander.
+ (fixuns_trunchfhi2): Likewise.
+ (*fixuns_trunchfsi2zext): New define_insn.
+ * config/i386/sse.md (ssePHmodelower): New mode_attr.
+ (fix<fixunssuffix>_trunc<ssePHmodelower><mode>2):
+ New expander for same element vector fix_truncate.
+ (fix<fixunssuffix>_trunc<ssePHmodelower><mode>2):
+ Likewise for V4HF to V4SI/V4DI fix_truncate.
+ (fix<fixunssuffix>_truncv2hfv2di2):
+ Likeise for V2HF to V2DI fix_truncate.
+
+2021-09-23 Hongyu Wang <hongyu.wang@intel.com>
+
+ * config/i386/i386.md (<code>hf3): New expander.
+
+2021-09-23 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/sse.md (FMAMODEM): extend to handle FP16.
+ (VFH_SF_AVX512VL): Extend to handle HFmode.
+ (VF_SF_AVX512VL): Deleted.
+
+2021-09-23 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/i386.md (rinthf2): New expander.
+ (nearbyinthf2): New expander.
+
+2021-09-23 Aldy Hernandez <aldyh@redhat.com>
+
+ * tree-ssa-dom.c (class dom_jump_threader_simplifier): Rename...
+ (class dom_jt_state): ...this and provide virtual overrides.
+ (dom_jt_state::register_equiv): New.
+ (class dom_jt_simplifier): Rename from
+ dom_jump_threader_simplifier.
+ (dom_jump_threader_simplifier::simplify): Rename...
+ (dom_jt_simplifier::simplify): ...to this.
+ (pass_dominator::execute): Use dom_jt_simplifier and
+ dom_jt_state.
+ * tree-ssa-threadedge.c (jump_threader::jump_threader):
+ Clean-up.
+ (jt_state::register_equivs_stmt): Abstract out...
+ (jump_threader::record_temporary_equivalences_from_stmts_at_dest):
+ ...from here.
+ (jump_threader::thread_around_empty_blocks): Update state.
+ (jump_threader::thread_through_normal_block): Same.
+ (jt_state::jt_state): Remove.
+ (jt_state::push): Remove pass specific bits. Keep block vector
+ updated.
+ (jt_state::append_path): New.
+ (jt_state::pop): Remove pass specific bits.
+ (jt_state::register_equiv): Same.
+ (jt_state::record_ranges_from_stmt): Same.
+ (jt_state::register_equivs_on_edge): Same. Rename...
+ (jt_state::register_equivs_edge): ...to this.
+ (jt_state::dump): New.
+ (jt_state::debug): New.
+ (jump_threader_simplifier::simplify): Remove.
+ (jt_state::get_path): New.
+ * tree-ssa-threadedge.h (class jt_simplifier): Make into a base
+ class. Expose common functionality as virtual methods.
+ (class jump_threader_simplifier): Same. Rename...
+ (class jt_simplifier): ...to this.
+ * tree-vrp.c (class vrp_jump_threader_simplifier): Rename...
+ (class vrp_jt_simplifier): ...to this. Provide pass specific
+ overrides.
+ (class vrp_jt_state): New.
+ (vrp_jump_threader_simplifier::simplify): Rename...
+ (vrp_jt_simplifier::simplify): ...to this. Inline code from
+ what used to be the base class.
+ (vrp_jump_threader::vrp_jump_threader): Use vrp_jt_state and
+ vrp_jt_simplifier.
+
+2021-09-22 Tobias Burnus <tobias@codesourcery.com>
+
+ PR fortran/55534
+ * doc/invoke.texi (-Wno-missing-include-dirs.): Document Fortran
+ behavior.
+
+2021-09-22 Roger Sayle <roger@nextmovesoftware.com>
+ Richard Biener <rguenther@suse.de>
+
+ * match.pd (negation simplifications): Implement some negation
+ folding transformations from fold-const.c's fold_negate_expr.
+ * tree-ssa-sccvn.c (vn_nary_build_or_lookup_1): Add a SIMPLIFY
+ argument, to control whether the op should be simplified prior
+ to looking up/assigning a value number.
+ (vn_nary_build_or_lookup): Update call to vn_nary_build_or_lookup_1.
+ (vn_nary_simplify): Likewise.
+ (visit_nary_op): Likewise, but when constructing a NEGATE_EXPR
+ now call vn_nary_build_or_lookup_1 disabling simplification.
+
+2021-09-22 Jiufu Guo <guojiufu@linux.ibm.com>
+
+ PR tree-optimization/102087
+ * tree-ssa-loop-niter.c (number_of_iterations_until_wrap):
+ Update bound/cmp/control for niter.
+
+2021-09-22 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-fold.cc (fold_using_range::range_of_range_op):
+ Move check for non-empty BB here.
+ (fur_source::register_outgoing_edges): ...from here.
+
+2021-09-22 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc (path_range_query::internal_range_of_expr):
+ Remove call to improve_range_with_equivs.
+ (path_range_query::improve_range_with_equivs): Remove
+ * gimple-range-path.h: Remove improve_range_with_equivs.
+
+2021-09-22 dianhong xu <dianhong.xu@intel.com>
+
+ * config/i386/avx512fp16intrin.h:
+ (_mm512_mask_blend_ph): New intrinsic.
+ (_mm512_permutex2var_ph): Ditto.
+ (_mm512_permutexvar_ph): Ditto.
+ * config/i386/avx512fp16vlintrin.h:
+ (_mm256_mask_blend_ph): New intrinsic.
+ (_mm256_permutex2var_ph): Ditto.
+ (_mm256_permutexvar_ph): Ditto.
+ (_mm_mask_blend_ph): Ditto.
+ (_mm_permutex2var_ph): Ditto.
+ (_mm_permutexvar_ph): Ditto.
+
+2021-09-22 dianhong xu <dianhong.xu@intel.com>
+
+ * config/i386/avx512fp16intrin.h: Add new intrinsics.
+ (_mm512_conj_pch): New intrinsic.
+ (_mm512_mask_conj_pch): Ditto.
+ (_mm512_maskz_conj_pch): Ditto.
+ * config/i386/avx512fp16vlintrin.h: Add new intrinsics.
+ (_mm256_conj_pch): New intrinsic.
+ (_mm256_mask_conj_pch): Ditto.
+ (_mm256_maskz_conj_pch): Ditto.
+ (_mm_conj_pch): Ditto.
+ (_mm_mask_conj_pch): Ditto.
+ (_mm_maskz_conj_pch): Ditto.
+
+2021-09-22 dianhong xu <dianhong.xu@intel.com>
+
+ * config/i386/avx512fp16intrin.h (_MM512_REDUCE_OP): New macro
+ (_mm512_reduce_add_ph): New intrinsic.
+ (_mm512_reduce_mul_ph): Ditto.
+ (_mm512_reduce_min_ph): Ditto.
+ (_mm512_reduce_max_ph): Ditto.
+ * config/i386/avx512fp16vlintrin.h
+ (_MM256_REDUCE_OP/_MM_REDUCE_OP): New macro.
+ (_mm256_reduce_add_ph): New intrinsic.
+ (_mm256_reduce_mul_ph): Ditto.
+ (_mm256_reduce_min_ph): Ditto.
+ (_mm256_reduce_max_ph): Ditto.
+ (_mm_reduce_add_ph): Ditto.
+ (_mm_reduce_mul_ph): Ditto.
+ (_mm_reduce_min_ph): Ditto.
+ (_mm_reduce_max_ph): Ditto.
+
+2021-09-22 dianhong xu <dianhong.xu@intel.com>
+
+ * config/i386/avx512fp16intrin.h (__m512h_u, __m256h_u,
+ __m128h_u): New typedef.
+ (_mm512_load_ph): New intrinsic.
+ (_mm256_load_ph): Ditto.
+ (_mm_load_ph): Ditto.
+ (_mm512_loadu_ph): Ditto.
+ (_mm256_loadu_ph): Ditto.
+ (_mm_loadu_ph): Ditto.
+ (_mm512_store_ph): Ditto.
+ (_mm256_store_ph): Ditto.
+ (_mm_store_ph): Ditto.
+ (_mm512_storeu_ph): Ditto.
+ (_mm256_storeu_ph): Ditto.
+ (_mm_storeu_ph): Ditto.
+ (_mm512_abs_ph): Ditto.
+ * config/i386/avx512fp16vlintrin.h
+ (_mm_abs_ph): Ditto.
+ (_mm256_abs_ph): Ditto.
+
+2021-09-22 Andreas Krebbel <krebbel@linux.ibm.com>
+
+ * config/s390/tpf.md (prologue_tpf, epilogue_tpf): Add cc clobber.
+
+2021-09-22 Andreas Krebbel <krebbel@linux.ibm.com>
+
+ PR target/102222
+ * config/s390/s390.c (s390_expand_insv): Emit a normal move if it
+ is actually a full copy of the source operand into the target.
+ Don't emit a strict low part move if source and target mode match.
+
+2021-09-22 Jakub Jelinek <jakub@redhat.com>
+
+ PR middle-end/102415
+ * omp-expand.c (expand_omp_single): If region->exit is NULL,
+ assert region->entry is GIMPLE_OMP_SCOPE region and return.
+
+2021-09-22 Jakub Jelinek <jakub@redhat.com>
+
+ * tree.h (OMP_CLAUSE_ALLOCATE_ALIGN): Define.
+ * tree.c (omp_clause_num_ops): Change number of OMP_CLAUSE_ALLOCATE
+ arguments from 2 to 3.
+ * tree-pretty-print.c (dump_omp_clause): Print allocator() around
+ allocate clause allocator and print align if present.
+ * omp-low.c (scan_sharing_clauses): Force allocate_map entry even
+ for omp_default_mem_alloc if align modifier is present. If align
+ modifier is present, use TREE_LIST to encode both allocator and
+ align.
+ (lower_private_allocate, lower_rec_input_clauses, create_task_copyfn):
+ Handle align modifier on allocator clause if present.
+
+2021-09-22 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/i386.md (define_attr "isa"): Add
+ fma_or_avx512vl.
+ (define_attr "enabled"): Correspond fma_or_avx512vl to
+ TARGET_FMA || TARGET_AVX512VL.
+ * config/i386/mmx.md (fmav2sf4): Extend to AVX512 fma.
+ (fmsv2sf4): Ditto.
+ (fnmav2sf4): Ditto.
+ (fnmsv2sf4): Ditto.
+
+2021-09-22 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/i386.md (cstorehf3): New define_expand.
+
+2021-09-22 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/i386.md (<rounding_insn>hf2): New expander.
+ (sse4_1_round<mode>2): Extend from MODEF to MODEFH.
+ * config/i386/sse.md (*sse4_1_round<ssescalarmodesuffix>):
+ Extend from VF_128 to VFH_128.
+
+2021-09-22 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/i386-features.c (i386-features.c): Handle
+ E_HFmode.
+ * config/i386/i386.md (sqrthf2): New expander.
+ (*sqrthf2): New define_insn.
+ * config/i386/sse.md
+ (*<sse>_vmsqrt<mode>2<mask_scalar_name><round_scalar_name>):
+ Extend to VFH_128.
+
+2021-09-22 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/avx512fp16intrin.h (_mm_mask_fcmadd_sch):
+ New intrinsic.
+ (_mm_mask3_fcmadd_sch): Likewise.
+ (_mm_maskz_fcmadd_sch): Likewise.
+ (_mm_fcmadd_sch): Likewise.
+ (_mm_mask_fmadd_sch): Likewise.
+ (_mm_mask3_fmadd_sch): Likewise.
+ (_mm_maskz_fmadd_sch): Likewise.
+ (_mm_fmadd_sch): Likewise.
+ (_mm_mask_fcmadd_round_sch): Likewise.
+ (_mm_mask3_fcmadd_round_sch): Likewise.
+ (_mm_maskz_fcmadd_round_sch): Likewise.
+ (_mm_fcmadd_round_sch): Likewise.
+ (_mm_mask_fmadd_round_sch): Likewise.
+ (_mm_mask3_fmadd_round_sch): Likewise.
+ (_mm_maskz_fmadd_round_sch): Likewise.
+ (_mm_fmadd_round_sch): Likewise.
+ (_mm_fcmul_sch): Likewise.
+ (_mm_mask_fcmul_sch): Likewise.
+ (_mm_maskz_fcmul_sch): Likewise.
+ (_mm_fmul_sch): Likewise.
+ (_mm_mask_fmul_sch): Likewise.
+ (_mm_maskz_fmul_sch): Likewise.
+ (_mm_fcmul_round_sch): Likewise.
+ (_mm_mask_fcmul_round_sch): Likewise.
+ (_mm_maskz_fcmul_round_sch): Likewise.
+ (_mm_fmul_round_sch): Likewise.
+ (_mm_mask_fmul_round_sch): Likewise.
+ (_mm_maskz_fmul_round_sch): Likewise.
+ * config/i386/i386-builtin.def: Add corresponding new builtins.
+ * config/i386/sse.md
+ (avx512fp16_fmaddcsh_v8hf_maskz<round_expand_name>): New expander.
+ (avx512fp16_fcmaddcsh_v8hf_maskz<round_expand_name>): Ditto.
+ (avx512fp16_fma_<complexopname>sh_v8hf<mask_scalarcz_name><round_scalarcz_name>):
+ New define insn.
+ (avx512fp16_<complexopname>sh_v8hf_mask<round_name>): Ditto.
+ (avx512fp16_<complexopname>sh_v8hf<mask_scalarc_name><round_scalarcz_name>):
+ Ditto.
+ * config/i386/subst.md (mask_scalarcz_name): New.
+ (mask_scalarc_name): Ditto.
+ (mask_scalarc_operand3): Ditto.
+ (mask_scalarcz_operand4): Ditto.
+ (round_scalarcz_name): Ditto.
+ (round_scalarc_mask_operand3): Ditto.
+ (round_scalarcz_mask_operand4): Ditto.
+ (round_scalarc_mask_op3): Ditto.
+ (round_scalarcz_mask_op4): Ditto.
+ (round_scalarcz_constraint): Ditto.
+ (round_scalarcz_nimm_predicate): Ditto.
+ (mask_scalarcz): Ditto.
+ (mask_scalarc): Ditto.
+ (round_scalarcz): Ditto.
+
+2021-09-22 liuhongt <hongtao.liu@intel.com>
+
+ * config/i386/avx512fp16intrin.h (_mm512_fcmadd_pch):
+ New intrinsic.
+ (_mm512_mask_fcmadd_pch): Likewise.
+ (_mm512_mask3_fcmadd_pch): Likewise.
+ (_mm512_maskz_fcmadd_pch): Likewise.
+ (_mm512_fmadd_pch): Likewise.
+ (_mm512_mask_fmadd_pch): Likewise.
+ (_mm512_mask3_fmadd_pch): Likewise.
+ (_mm512_maskz_fmadd_pch): Likewise.
+ (_mm512_fcmadd_round_pch): Likewise.
+ (_mm512_mask_fcmadd_round_pch): Likewise.
+ (_mm512_mask3_fcmadd_round_pch): Likewise.
+ (_mm512_maskz_fcmadd_round_pch): Likewise.
+ (_mm512_fmadd_round_pch): Likewise.
+ (_mm512_mask_fmadd_round_pch): Likewise.
+ (_mm512_mask3_fmadd_round_pch): Likewise.
+ (_mm512_maskz_fmadd_round_pch): Likewise.
+ (_mm512_fcmul_pch): Likewise.
+ (_mm512_mask_fcmul_pch): Likewise.
+ (_mm512_maskz_fcmul_pch): Likewise.
+ (_mm512_fmul_pch): Likewise.
+ (_mm512_mask_fmul_pch): Likewise.
+ (_mm512_maskz_fmul_pch): Likewise.
+ (_mm512_fcmul_round_pch): Likewise.
+ (_mm512_mask_fcmul_round_pch): Likewise.
+ (_mm512_maskz_fcmul_round_pch): Likewise.
+ (_mm512_fmul_round_pch): Likewise.
+ (_mm512_mask_fmul_round_pch): Likewise.
+ (_mm512_maskz_fmul_round_pch): Likewise.
+ * config/i386/avx512fp16vlintrin.h (_mm_fmadd_pch):
+ New intrinsic.
+ (_mm_mask_fmadd_pch): Likewise.
+ (_mm_mask3_fmadd_pch): Likewise.
+ (_mm_maskz_fmadd_pch): Likewise.
+ (_mm256_fmadd_pch): Likewise.
+ (_mm256_mask_fmadd_pch): Likewise.
+ (_mm256_mask3_fmadd_pch): Likewise.
+ (_mm256_maskz_fmadd_pch): Likewise.
+ (_mm_fcmadd_pch): Likewise.
+ (_mm_mask_fcmadd_pch): Likewise.
+ (_mm_mask3_fcmadd_pch): Likewise.
+ (_mm_maskz_fcmadd_pch): Likewise.
+ (_mm256_fcmadd_pch): Likewise.
+ (_mm256_mask_fcmadd_pch): Likewise.
+ (_mm256_mask3_fcmadd_pch): Likewise.
+ (_mm256_maskz_fcmadd_pch): Likewise.
+ (_mm_fmul_pch): Likewise.
+ (_mm_mask_fmul_pch): Likewise.
+ (_mm_maskz_fmul_pch): Likewise.
+ (_mm256_fmul_pch): Likewise.
+ (_mm256_mask_fmul_pch): Likewise.
+ (_mm256_maskz_fmul_pch): Likewise.
+ (_mm_fcmul_pch): Likewise.
+ (_mm_mask_fcmul_pch): Likewise.
+ (_mm_maskz_fcmul_pch): Likewise.
+ (_mm256_fcmul_pch): Likewise.
+ (_mm256_mask_fcmul_pch): Likewise.
+ (_mm256_maskz_fcmul_pch): Likewise.
+ * config/i386/i386-builtin-types.def (V8HF_FTYPE_V8HF_V8HF_V8HF,
+ V8HF_FTYPE_V16HF_V16HF_V16HF, V16HF_FTYPE_V16HF_V16HF_V16HF_UQI,
+ V32HF_FTYPE_V32HF_V32HF_V32HF_INT,
+ V32HF_FTYPE_V32HF_V32HF_V32HF_UHI_INT): Add new builtin types.
+ * config/i386/i386-builtin.def: Add new builtins.
+ * config/i386/i386-expand.c: Handle new builtin types.
+ * config/i386/subst.md (SUBST_CV): New.
+ (maskc_name): Ditto.
+ (maskc_operand3): Ditto.
+ (maskc): Ditto.
+ (sdc_maskz_name): Ditto.
+ (sdc_mask_op4): Ditto.
+ (sdc_mask_op5): Ditto.
+ (sdc_mask_mode512bit_condition): Ditto.
+ (sdc): Ditto.
+ (round_maskc_operand3): Ditto.
+ (round_sdc_mask_operand4): Ditto.
+ (round_maskc_op3): Ditto.
+ (round_sdc_mask_op4): Ditto.
+ (round_saeonly_sdc_mask_operand5): Ditto.
+ * config/i386/sse.md (unspec): Add complex fma unspecs.
+ (avx512fmaskcmode): New.
+ (UNSPEC_COMPLEX_F_C_MA): Ditto.
+ (UNSPEC_COMPLEX_F_C_MUL): Ditto.
+ (complexopname): Ditto.
+ (<avx512>_fmaddc_<mode>_maskz<round_expand_name>): New expander.
+ (<avx512>_fcmaddc_<mode>_maskz<round_expand_name>): Ditto.
+ (fma_<complexopname>_<mode><sdc_maskz_name><round_name>): New
+ define insn.
+ (<avx512>_<complexopname>_<mode>_mask<round_name>): Ditto.
+ (<avx512>_<complexopname>_<mode><maskc_name><round_name>): Ditto.
+
+2021-09-22 Kewen Lin <linkw@linux.ibm.com>
+
+ * config/rs6000/rs6000.opt (rs6000-density-pct-threshold,
+ rs6000-density-size-threshold, rs6000-density-penalty,
+ rs6000-density-load-pct-threshold,
+ rs6000-density-load-num-threshold): New parameter.
+ * config/rs6000/rs6000.c (rs6000_density_test): Adjust with
+ corresponding parameters.
+
+2021-09-21 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc (path_range_query::defined_outside_path):
+ New.
+ (path_range_query::range_on_path_entry): New.
+ (path_range_query::internal_range_of_expr): Resolve unknowns
+ with ranger.
+ (path_range_query::improve_range_with_equivs): New.
+ (path_range_query::ssa_range_in_phi): Resolve unknowns with
+ ranger.
+ * gimple-range-path.h (class path_range_query): Add
+ defined_outside_path, range_on_path_entry, and
+ improve_range_with_equivs.
+
+2021-09-21 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc (path_range_query::add_to_imports): New.
+ (path_range_query::add_copies_to_imports): New.
+ (path_range_query::precompute_ranges): Call
+ add_copies_to_imports.
+ * gimple-range-path.h (class path_range_query): Add prototypes
+ for add_copies_to_imports and add_to_imports.
+
+2021-09-21 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-path.cc (path_range_query::range_defined_in_block):
+ Remove useless code.
+
+2021-09-21 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-fold.h (class fur_source): Make oracle protected.
+ * gimple-range-path.cc (path_range_query::path_range_query): Add
+ resolve argument. Initialize oracle.
+ (path_range_query::~path_range_query): Delete oracle.
+ (path_range_query::range_of_stmt): Adapt to use relations.
+ (path_range_query::precompute_ranges): Pre-compute relations.
+ (class jt_fur_source): New
+ (jt_fur_source::jt_fur_source): New.
+ (jt_fur_source::register_relation): New.
+ (jt_fur_source::query_relation): New.
+ (path_range_query::precompute_relations): New.
+ (path_range_query::precompute_phi_relations): New.
+ * gimple-range-path.h (path_range_query): Add resolve argument.
+ Add oracle, precompute_relations, precompute_phi_relations.
+ * tree-ssa-threadbackward.c (back_threader::back_threader): Pass
+ resolve argument to solver.
+
+2021-09-21 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-fold.cc (fold_using_range::range_of_range_op):
+ Rename postfold_gcond_edges to register_outgoing_edges and
+ adapt.
+ (fold_using_range::postfold_gcond_edges): Rename...
+ (fur_source::register_outgoing_edges): ...to this.
+ * gimple-range-fold.h (postfold_gcond_edges): Rename to
+ register_outgoing_edges and move to fur_source.
+
+2021-09-21 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-fold.cc (fold_using_range::range_of_phi): Check
+ dom_info_available_p.
+
+2021-09-21 Aldy Hernandez <aldyh@redhat.com>
+
+ * gimple-range-cache.cc (non_null_ref::non_null_ref): Use create
+ and quick_grow_cleared instead of safe_grow_cleared.
+
+2021-09-21 Thomas Schwinge <thomas@codesourcery.com>
+
+ PR other/102408
+ * omp-oacc-neuter-broadcast.cc (oacc_do_neutering): Evaluate
+ 'random ()' to '0'.
+
+2021-09-21 Richard Earnshaw <rearnsha@arm.com>
+
+ * configure.ac: Detect when the assembler supports new-style
+ architecture extensions.
+ * common/config/arm/arm-common.c (arm_rewrite_mcpu): Return
+ the full CPU string if the assembler can grok it.
+ (arm_rewrite_march): Likewise but for the architecture.
+ * config.in: Regenerate.
+ * configure: Regenerate.
+
+2021-09-21 Richard Biener <rguenther@suse.de>
+
+ PR tree-optimization/102421
+ * tree-vect-loop.c (vect_dissolve_slp_only_groups): Copy and
+ adjust alignment info.
+
+2021-09-21 Kewen Lin <linkw@linux.ibm.com>
+
+ * ipa-fnsummary.c (ipa_fn_summary_write): Remove inconsistent
+ bitfield stream out.
+
2021-09-20 Andrew MacLeod <amacleod@redhat.com>
* gimple-range-fold.cc (fold_using_range::range_of_phi): Ignore
diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP
index ed865cb..e528add 100644
--- a/gcc/DATESTAMP
+++ b/gcc/DATESTAMP
@@ -1 +1 @@
-20210921
+20211007
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 56d9baf..feadd5e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,1734 @@
+2021-10-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (gnat_to_gnu): Do not wrap boolean values
+ referenced in pragmas.
+
+2021-10-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Subprogram_Body_to_gnu): Do not set the
+ DECL_DISREGARD_INLINE_LIMITS flag if -gnatd.8 is specified.
+
+2021-10-05 Bob Duff <duff@adacore.com>
+
+ * gcc-interface/trans.c (set_end_locus_from_node): Check that
+ Handled_Statement_Sequence is not Empty before calling
+ End_Label, because the Empty node has no End_Label, and
+ depending on the exact node layout chosen by gen_il, calling
+ End_Label might crash, or might work OK by accident.
+
+2021-10-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/cuintp.c: Adjust placement of include directive.
+ * gcc-interface/targtyps.c: Likewise.
+
+2021-10-05 Alexandre Oliva <oliva@adacore.com>
+
+ * doc/gnat_rm.rst: Add...
+ * doc/gnat_rm/security_hardening_features.rst: New.
+ * doc/gnat_rm/about_this_guide.rst: Link to new chapter.
+ * gnat_rm.texi: Regenerate.
+ * gcc-interface/utils.c (handle_strub_attribute): New.
+ (gnat_internal_attribute_table): Add strub.
+ * libgnat/a-except.adb: Make Rcheck_CE_* strub-callable.
+ * libgnat/a-except.ads (Raise_Exception): Likewise.
+ (Raise_Exception_Always): Likewise.
+ * libgnat/s-arit128.ads (Multiply_With_Ovflo_Check128):
+ Likewise.
+ * libgnat/s-arit64.ads (Multiply_With_Ovflo_Check64):
+ Likewise.
+ * libgnat/s-secsta.ads (SS_Allocate, SS_Mark, SS_Release):
+ Likewise.
+
+2021-10-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch9.adb (Install_Private_Data_Declarations): Copy the Sloc of
+ components for the local renamings as well as the Comes_From_Source
+ flag, and also set Warnings_Off on them. Use Nam local variable.
+
+2021-10-05 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnarl/a-tasini.ads (Set_Initialization_Handler): Update
+ comments.
+
+2021-10-05 Corentin Gay <gay@adacore.com>
+
+ * init.c (QNX): Add #include errno.h.
+
+2021-10-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_attr.adb (Expand_Fpt_Attribute): Likewise.
+ * snames.ads-tmpl (Name_Unaligned_Valid): Delete.
+
+2021-10-05 Etienne Servais <servais@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Forbid use of
+ Compile_Time_(Error|Warning) as configuration pragma.
+ * doc/gnat_ugn/the_gnat_compilation_model.rst:
+ Compile_Time_(Error|Warning) and Compiler_Unit(_Warning) are not
+ configuration pragmas and shall not be listed as such. The
+ following pragmas are either obsolete or undocumented:
+ No_Run_Time, Propagate_Exceptions, Rational, Ravenscar,
+ Restricted_Run_Time, Short_Descriptors, Universal_Data. Fix
+ some typos (notably on Restriction_Warnings).
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Move
+ Rename_Pragma documentation to alphabetical order.
+ * gnat_rm.texi, gnat_ugn.texi: Regenerate.
+
+2021-10-05 Corentin Gay <gay@adacore.com>
+
+ * adaint.c (QNX): Add #include for sys/time.h.
+
+2021-10-05 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-forstr.adb (Next_Format): When there is no more
+ format specifier found issue a proper error message instead of
+ raising a contraint error.
+
+2021-10-05 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-forstr.adb (Get_Formatted): Fix computation of the
+ number of zero to use in the formatted string. This was a wrong
+ copy/paste.
+
+2021-10-05 Pascal Obry <obry@adacore.com>
+
+ * libgnat/g-forstr.adb (Get_Formatted): Minor code clean-up.
+
+2021-10-05 Etienne Servais <servais@adacore.com>
+
+ * libgnat/a-zchhan.ads, libgnat/a-zchhan.adb
+ (Character_Set_Version, Is_Basic, To_Basic): New.
+ * libgnat/a-zchuni.ads, libgnat/a-zchuni.adb (Is_Basic,
+ To_Basic): New.
+
+2021-10-05 Yannick Moy <moy@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Improve error message.
+
+2021-10-05 Gary Dismukes <dismukes@adacore.com>
+
+ * aspects.ads (type Aspect_Id): Add
+ Aspect_Designated_Storage_Model and Aspect_Storage_Model_Type.
+ (Aspect_Argument): Add associations for the above new aspects.
+ (Is_Representation_Aspect): Likewise.
+ (Aspect_Names, Aspect_Delay): Likewise.
+ * exp_ch4.adb (Expand_N_Allocator): Call Find_Storage_Op rather
+ than Find_Prim_Op.
+ * exp_intr.adb (Expand_Unc_Deallocation): Likewise.
+ * exp_util.ads (Find_Storage_Op): New function that locates
+ either a primitive operation of a storage pool or an operation
+ of a storage-model type specified in its Storage_Model_Type
+ aspect.
+ * exp_util.adb (Find_Storage_Op): New function that calls either
+ Find_Prim_Op or Get_Storage_Model_Type_Entity to locate a
+ storage-related operation that is associated with a type.
+ * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Analyzes,
+ resolves, and validates the arguments of aspect
+ Designated_Storage_Model_Type.
+ (Analyze_Aspect_Specifications): Sets delay-related flags on
+ storage-model aspects when Delay_Required. Checks that aspect
+ Designated_Storage_Model is only specified for an access type
+ and that aspect Storage_Model_Type is only specified on an
+ immutably limited type. Also records such aspects for their
+ associated types.
+ (Check_Aspect_At_Freeze_Point): Resolve each of the argument
+ associations given for a Storage_Model_Type aspect.
+ (Resolve_Storage_Model_Type_Argument): New procedure that
+ resolves an argument given in the association for a given entity
+ name associated with a type with aspect Storage_Model_Type,
+ ensuring that it has the proper kind or profile.
+ (Validate_Storage_Model_Type_Aspect): New procedure that checks
+ the legality and completeness of the entity associations given
+ in a Storage_Model_Type aspect.
+ * sem_util.ads (package Storage_Model_Support): New nested
+ package that encapsulates a set of convenient utility functions
+ for retrieving entities, etc. associated with
+ storage-model-related types and objects.
+ (Get_Storage_Model_Type_Entity): New function to return a
+ specified entity associated with a type that has aspect
+ Storage_Model_Type.
+ (Has_Designated_Storage_Model_Aspect): New function that returns
+ whether a type has aspect Designated_Storage_Model.
+ (Has_Storage_Model_Type_Aspect): New function that returns
+ whether a type has aspect Storage_Model_Type.
+ (Storage_Model_Object): New function that returns the object
+ Entity_Id associated with a type's Designated_Storage_Model
+ aspect.
+ (Storage_Model_Type): New function that returns the type
+ associated with a storage-model object (when the object's type
+ specifies Storage_Model_Type).
+ (Storage_Model_Address_Type): New function that returns the
+ Address_Type associated with a type that has aspect
+ Storage_Model_Type.
+ (Storage_Model_Null_Address): New function that returns the
+ Null_Address constant associated with a type that has aspect
+ Storage_Model_Type.
+ (Storage_Model_Allocate): New function that returns the Allocate
+ procedure associated with a type that has aspect
+ Storage_Model_Type.
+ (Storage_Model_Deallocate): New function that returns the
+ Deallocate procedure associated with a type that has aspect
+ Storage_Model_Type.
+ (Storage_Model_Copy_From): New function that returns the
+ Copy_From procedure associated with a type that has aspect
+ Storage_Model_Type.
+ (Storage_Model_Copy_To): New function that returns the Copy_To
+ procedure associated with a type that has aspect
+ Storage_Model_Type.
+ (Storage_Model_Storage_Size): New function that returns the
+ Storage_Size function associated with a type that has aspect
+ Storage_Model_Type.
+ * sem_util.adb (package Storage_Model_Support): Body of new
+ nested package that contains the implementations the utility
+ functions declared in the spec of this package.
+ * snames.ads-tmpl: Add new names Name_Designated_Storage_Pool,
+ Name_Storage_Model, Name_Storage_Model_Type, Name_Address_Type,
+ Name_Copy_From, Name_Copy_To, and Name_Null_Address for the new
+ aspects and associated aspect arguments.
+
+2021-10-05 Richard Kenner <kenner@adacore.com>
+
+ * debug.adb: Add documentation for -gnatd_t.
+
+2021-10-05 Corentin Gay <gay@adacore.com>
+
+ * sysdep.c (__gnat_is_file_not_found_error): Add else if case.
+
+2021-10-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_util.adb (Build_Class_Wide_Expression): Replace entities
+ of both identifiers and operator symbols.
+
+2021-10-05 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_ch3.adb (Derive_Subprogram): Copy ghost status from parent
+ to derived subprogram.
+
+2021-10-05 Joffrey Huguet <huguet@adacore.com>
+
+ * libgnat/a-strunb.ads, libgnat/a-strunb__shared.ads: Add
+ Default_Initial_Condition to Unbounded_String.
+
+2021-10-05 Claire Dross <dross@adacore.com>
+
+ * libgnat/a-cfdlli.ads: Use pragma Assertion_Policy to disable
+ contract cases at execution.
+ * libgnat/a-cfinve.ads: Idem.
+ * libgnat/a-cofove.ads: Idem.
+ * libgnat/a-cfhase.ads: Idem.
+ * libgnat/a-cfhama.ads: Idem.
+ * libgnat/a-cforse.ads: Idem.
+ * libgnat/a-cforma.ads: Idem.
+
+2021-10-05 Bob Duff <duff@adacore.com>
+
+ * par-ch4.adb (P_Iterated_Component_Association): Parse these
+ features the same way in all language versions. Move the call
+ to Error_Msg_Ada_2022_Feature into semantic analysis.
+ * sem_aggr.adb (Resolve_Iterated_Component_Association,
+ Resolve_Iterated_Association): Move the call to
+ Error_Msg_Ada_2022_Feature here from par-ch4.adb.
+
+2021-10-05 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Resolve): Recognize specially that case.
+
+2021-10-05 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-strmap.adb: Add ghost code for proof.
+ (To_Range): This is the most involved proof, as it requires
+ creating the result of the call to To_Domain as a ghost
+ variable, and show the unicity of this result in order to prove
+ the postcondition.
+ * libgnat/a-strmap.ads: (SPARK_Proof_Sorted_Character_Sequence):
+ New ghost function.
+ (To_Domain): Add postcondition regarding sorting of result.
+ (To_Range): Fix postcondition that should compare Length instead
+ of Last for the results of To_Domain and To_Range, as the value
+ of Last for an empty result is not specified in the Ada RM.
+
+2021-10-05 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-chahan.adb: Add loop invariants as needed to prove
+ subprograms. Also use extended return statements where
+ appropriate and not done already. Mark data with
+ Relaxed_Initialization where needed for initialization by parts.
+ Convert regular functions to expression functions where needed
+ for proof.
+ * libgnat/a-chahan.ads: Add postconditions.
+ * libgnat/a-strmap.ads (Model): New ghost function to create a
+ publicly visible model of the private data Character_Mapping,
+ needed in order to prove subprograms in Ada.Characters.Handling.
+
+2021-10-04 Justin Squirek <squirek@adacore.com>
+
+ * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst:
+ Add new entry for No_Dynamic_Accessibility_Checks documenting
+ behavior.
+ * gnat_rm.texi: Regenerate.
+ * exp_ch4.adb (Expand_N_In): Perform special expansion for
+ membership tests when No_Dynamic_Accessibility_Checks is active.
+ * sem_attr.adb (Resolve_Attribute): Skip static accessibility
+ check on actuals for anonymous access type formal parameters,
+ and add constants for readability.
+ * sem_util.adb (Function_Call_Or_Allocator_Level): Use the
+ innermost master for determining the level for function calls
+ within the alternative accessibility model.
+ (Type_Access_Level): Properly get the level for anonymous access
+ function result types.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * doc/gnat_ugn/building_executable_programs_with_gnat.rst
+ (gnateA): This switch no longer looks at the formal parameter
+ type being composite (as originally mandated by SPARK), but in
+ the parameter passing mechanism being not specified (as
+ currently mandated by Ada).
+ * gnat_ugn.texi: Regenerate.
+
+2021-10-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Operator_Symbol): Recognize strings as
+ operator names when they are the value of one of the Ada2022
+ aspects for User_Defined_Literals.
+ * sem_ch13.adb (Analyze_One_Aspect): Handle an aspect value
+ given by an Operator_Name.
+ (Validate_Literal_Aspect): Call Analyze_Operator_Symbol when
+ needed.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * gen_il-gen.adb (Put_Make_Spec): Don't emit the LF character in
+ the middle of a string, because the Put routine won't indent it
+ properly.
+
+2021-10-04 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * gnat_cuda.adb (Remove_CUDA_Device_Entities): New function.
+ (Expand_CUDA_Package): Call Remove_CUDA_Device_Entities.
+ * gnat_cuda.ads (Expand_CUDA_Package): Expand documentation.
+ * sem_prag.adb (Analyze_Pragma): Remove warning about
+ CUDA_Device not being implemented.
+
+2021-10-04 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch7.adb (Analyze_Package_Specification): For types marked
+ as Must_Have_Preelab_Init, we now check for the presence of a
+ Preelaborable_Initialization aspect on the type, and pass the
+ aspect's expression (if any) on the call to
+ Has_Preelaborable_Initialization (or pass Empty if the type has
+ no such aspect or the aspect has no associated expression).
+ * sem_util.ads (Has_Preelaborable_Initialization): Change
+ Boolean formal parameter Formal_Types_Have_Preelab_Init to
+ instead be a formal of type Node_Id (named Preelab_Init_Expr),
+ to allow passing an expression that may be a conjunction of
+ Preelaborable_Initialization aspects. Revise spec comment
+ accordingly (and remove ??? comment).
+ * sem_util.adb (Type_Named_In_Preelab_Init_Expression): New
+ nested function with a result indicating whether a given type is
+ named as the prefix of a Preelaborable_Initialization attribute
+ in the expression of a corresponding P_I aspect.
+ (Has_Preelaborable_Initialization): For generic formal derived
+ and private types, test whether the type is named in the
+ expression Preelab_Init_Expr (by calling
+ Type_Named_In_Preelab_Init_Expression), and if so, treat the
+ formal type as having preelaborable initialization (returning
+ True).
+ * libgnat/a-cobove.ads (Vector): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as Element_Type'Preelaborable_Initialization.
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+ * libgnat/a-cbdlli.ads (List): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as Element_Type'Preelaborable_Initialization.
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+ * libgnat/a-cbhama.ads (Map): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as (Element_Type'Preelaborable_Initialization and
+ Key_Type'Preelaborable_Initialization).
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+ * libgnat/a-cborma.ads (Map): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as (Element_Type'Preelaborable_Initialization and
+ Key_Type'Preelaborable_Initialization).
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+ * libgnat/a-cbhase.ads (Set): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as Element_Type'Preelaborable_Initialization.
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+ * libgnat/a-cborse.ads (Set): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as Element_Type'Preelaborable_Initialization.
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+ * libgnat/a-cbmutr.ads (Tree): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as Element_Type'Preelaborable_Initialization.
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+ * libgnat/a-coboho.ads (Holder): Replace pragma
+ Preelaborable_Initialization with the aspect, specifying its
+ value as Element_Type'Preelaborable_Initialization.
+ (Cursor): Replace pragma P_I with the aspect (defaulting to
+ True).
+
+2021-10-04 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-textio.adb: Mark body out of SPARK.
+ * libgnat/a-textio.ads: Mark spec in SPARK and private part out
+ of SPARK.
+ * sem.adb (Semantics.Do_Analyze): Similar to ghost code
+ attributes, save and restore value of
+ Ignore_SPARK_Mode_Pragmas_In_Instance.
+
+2021-10-04 Bob Duff <duff@adacore.com>
+
+ * libgnat/s-regpat.ads: Change Data_First to Data'First. Change
+ "still" to "always". Similar changes for Data_Last.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sprint.adb (Sprint_Node_Actual): Refactor code for generic
+ package and subprogram declarations.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Indexed_Component, Resolve_Slice): Rename
+ the local constant Name to Pref; remove repeated calls to
+ Prefix.
+
+2021-10-04 Matthieu Eyraud <eyraud@adacore.com>
+
+ * scos.ads: Extend the documentation.
+ * par_sco.adb (Process_Decisions): Emit specific SCOs for
+ quantified expressions.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * checks.adb (Selected_Range_Checks): Fix style.
+ * exp_ch4.adb (Expand_N_Slice): Fix style and comment.
+ * sem_res.adb (Resolve_Indexed_Component): Fix style.
+
+2021-10-04 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-strbou.ads: Add comments.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): Evaluation of attribute
+ Leading_Part with illegal second parameter is now similar to
+ evaluation of Remainder with its second parameter being zero.
+
+2021-10-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Declare_Expression): Use tree traversals
+ to perform name capture of local entities in the expression of
+ the construct.
+ * exp_util.adb (Possible_Side_Effects_In_SPARK): Do not apply to
+ the prefix of an attribute reference Reduce when that prefix is
+ an aggregate, because it will be expanded into a loop, and has
+ no identifiable type.
+
+2021-10-04 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch8.adb (Build_Class_Wide_Wrapper): Fix handling of
+ class-wide subtypes; required to handle chains of
+ instantiations. Adding also code to identify these wrappers and
+ properly resolve instantiations where the wrapper and a tagged
+ type primitive are visible.
+ * einfo.ads (Is_Class_Wide_Wrapper): Adding documentation.
+ * gen_il-fields.ads (Opt_Field_Enum): Adding
+ Is_Class_Wide_Wrapper.
+ * gen_il-gen-gen_entities.adb (Root_Entity_Type): Adding
+ semantic flag Is_Class_Wide_Wrapper.
+
+2021-10-04 Bob Duff <duff@adacore.com>
+
+ * einfo.ads (Declaration_Node): Document that Declaration_Node
+ for Itypes.
+ * einfo-utils.adb (Declaration_Node): Make it return Empty for
+ Itypes, or a proper type or subtype declaration.
+ * gen_il-gen.adb: Minor comment improvement.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Slice): Fix application of range checks
+ to slice range given as a subtype name.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Slice): Handle range given as a subtype
+ indication.
+
+2021-10-04 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_res.adb (Resolve_Slice): Add custom handling of attribute
+ Image and similar in CodePeer mode. This complements the
+ existing custom handling of these attributes in
+ Expand_N_Attribute_Reference.
+
+2021-10-04 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (Is_Variable): Add check for implicitly
+ dereferenced access types
+ (Is_Dependent_Component_Of_Mutable_Object): Set Prefix_Type when
+ not specified.
+
+2021-10-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_ugn/the_gnat_compilation_model.rst (Binding generation):
+ Document specific behavior for /include/-ending paths and update.
+ * gnat_ugn.texi: Regenerate.
+
+2021-10-04 Arnaud Charlet <charlet@adacore.com>
+
+ PR ada/102073
+ * socket.c (__gnat_gethostbyaddr, __gnat_inet_pton): Add missing
+ return statements.
+
+2021-10-04 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (Function_Or_Allocator_Level): Properly handle
+ direct function calls in the default alternative accessibility
+ checking mode.
+
+2021-10-04 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.adb (Is_Library_Level_Entity): Return False for
+ entities defined in E_Loop scopes. This change is not required
+ by the frontend; it is required by tools that depend on the
+ frontend sources.
+ * einfo-utils.adb (Is_Dynamic_Scope): Code cleanup.
+
+2021-10-04 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (Accessibility_Level): Add a case to handle
+ renamed subprograms in addition to renamed objects.
+
+2021-10-04 Doug Rupp <rupp@adacore.com>
+
+ * libgnarl/s-osinte__vxworks.ads (tlsKeyCreate): Return int.
+ * libgnarl/s-tpopsp__vxworks-rtp.adb (ERROR): Declare from
+ System.VxWorks.Ext.ERROR.
+ (Initialize): Declare IERR. Assert it.
+ * libgnarl/s-tpopsp__vxworks.adb (ERROR): Declare from
+ System.VxWorks.Ext.ERROR.
+ (Is_Valid_Task): Declare IERR. Test return.
+ * libgnarl/s-vxwext__kernel.adb (semDelete): Return STATUS.
+
+2021-10-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_disp.adb (Make_DT): Copy the Needs_Debug_Info flag from the
+ type onto the TSD object.
+
+2021-10-04 Steve Baird <baird@adacore.com>
+
+ * sem_util.adb (Is_Repeatedly_Evaluated): Handle the case of an
+ Old attribute reference that occurs within what was originally a
+ quantified expression but which expansion has transformed into
+ an Expression_With_Actions.
+
+2021-10-04 Steve Baird <baird@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Indexed_Component): The two improvements
+ described above.
+
+2021-10-01 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Do not call
+ Check_Subprogram_Variant if the subprogram is an ignored ghost
+ entity. Otherwise the compiler crashes (in debug builds) or
+ gives strange error messages (in production builds).
+
+2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * gnat_cuda.adb (Empty_CUDA_Global_Subprograms): New procedure.
+ (Expand_CUDA_Package): Call Empty_CUDA_Global_Subprograms.
+
+2021-10-01 Steve Baird <baird@adacore.com>
+
+ * checks.ads: Define a type Dimension_Set. Add an out-mode
+ parameter of this new type to Generate_Index_Checks so that
+ callers can know for which dimensions a check was generated. Add
+ an in-mode parameter of this new type to
+ Apply_Subscript_Validity_Checks so that callers can indicate
+ that no check is needed for certain dimensions.
+ * checks.adb (Generate_Index_Checks): Implement new
+ Checks_Generated parameter.
+ (Apply_Subscript_Validity_Checks): Implement new No_Check_Needed
+ parameter.
+ * exp_ch4.adb (Expand_N_Indexed_Component): Call
+ Apply_Subscript_Validity_Checks in more cases than before. This
+ includes declaring two new local functions,
+ (Is_Renamed_Variable_Name,
+ Type_Requires_Subscript_Validity_Checks_For_Reads): To help in
+ deciding whether to call Apply_Subscript_Validity_Checks.
+ Adjust to parameter profile changes in Generate_Index_Checks and
+ Apply_Subscript_Validity_Checks.
+
+2021-10-01 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_characteristics.rst: Document
+ the rounding mode assumed for dynamic computations as per 3.5.7(16).
+ * gnat_rm.texi: Regenerate.
+
+2021-10-01 Bob Duff <duff@adacore.com>
+
+ * table.ads (Table_Type): Remove "aliased"; no longer needed by
+ Atree. Besides it contradicted the comment a few lines above,
+ "-- Note: We do not make the table components aliased...".
+ * types.ads: Move type Slot to Atree.
+ * atree.ads: Move type Slot fromt Types to here. Move type
+ Node_Header from Seinfo to here.
+ * atree.adb: Avoid the need for aliased components of the Slots
+ table. Instead of 'Access, use a getter and setter. Misc
+ cleanups.
+ (Print_Statistics): Print statistics about node and entity kind
+ frequencies. Give 3 digit fractions instead of percentages.
+ * (Get_Original_Node_Count, Set_Original_Node_Count): Statistics
+ for calls to Original_Node and Set_Original_Node.
+ (Original_Node, Set_Original_Node): Gather statistics by calling
+ the above.
+ (Print_Field_Statistics): Print Original_Node statistics.
+ (Update_Kind_Statistics): Remove, and put all statistics
+ gathering under "if Atree_Statistics_Enabled", which is a flag
+ generated in Seinfo by Gen_IL.
+ * gen_il-gen.adb (Compute_Field_Offsets): Choose offsets of
+ Nkind, Ekind, and Homonym first. This causes a slight efficiency
+ improvement. Misc cleanups. Do not generate Node_Header; it is
+ now hand-written in Atree. When choosing the order in which to
+ assign offsets, weight by the frequency of the node type, so the
+ more common nodes get their field offsets assigned earlier. Add
+ more special cases.
+ (Compute_Type_Sizes): Remove this and related things.
+ There was a comment: "At some point we can instrument Atree to
+ print out accurate size statistics, and remove this code." We
+ have Atree statistics, so we now remove this code.
+ (Put_Seinfo): Generate Atree_Statistics_Enabled, which is equal
+ to Statistics_Enabled. This allows Atree to say "if
+ Atree_Statistics_Enabled then <gather statistics>" for
+ efficiency. When Atree_Statistics_Enabled is False, the "if ..."
+ will be optimized away.
+ * gen_il-internals.ads (Type_Frequency): New table of kind
+ frequencies.
+ * gen_il-internals.adb: Minor comment improvement.
+ * gen_il-fields.ads: Remove unused subtypes. Suppress style
+ checks in the Type_Frequency table. If we regenerate this
+ table (see -gnatd.A) we don't want to have to fiddle with
+ casing.
+ * impunit.adb: Minor.
+ * sinfo-utils.adb: Minor.
+ * debug.adb: Minor comment improvement.
+
+2021-10-01 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_type.adb (Specific_Type): Check that the type is tagged
+ before calling Interface_Present_In_Ancestor on it.
+
+2021-10-01 Eric Botcazou <ebotcazou@adacore.com>
+
+ * debug.adb (d.8): Document usage.
+ * fe.h (Debug_Flag_Dot_8): Declare.
+
+2021-10-01 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_util.adb (Enter_Name): Suppress hiding warning when in an
+ instance.
+
+2021-10-01 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute, case Type_Key): Attribute can
+ be applied to a formal type.
+ * sem_ch5.adb (Analyze_Case_Statement): If Extensions_Allowed is
+ not enabled, verify that the type of the expression is discrete.
+
+2021-10-01 Justin Squirek <squirek@adacore.com>
+
+ * exp_dbug.adb (Debug_Renaming_Declaration): Add check for
+ Entity present for Ren to prevent looking at unanalyzed nodes
+
+2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * atree.adb (Print_Statistics): Help CodePeer see Total as
+ greater than zero.
+ * gen_il-gen.adb (One_Comp): Annotate Field_Table as Modified.
+
+2021-10-01 Richard Kenner <kenner@adacore.com>
+
+ * gen_il-gen-gen_entities.adb (Evaluable_Kind,
+ Global_Name_Kind): Add.
+ * gen_il-types.ads (Evaluable_Kind, Global_Name_Kind): Likewise.
+
+2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * aspects.ads: Add CUDA_Device aspect.
+ * gnat_cuda.ads (Add_CUDA_Device_Entity): New subprogram.
+ * gnat_cuda.adb:
+ (Add_CUDA_Device_Entity): New subprogram.
+ (CUDA_Device_Entities_Table): New hashmap for CUDA_Device
+ entities.
+ (Get_CUDA_Device_Entities): New internal subprogram.
+ (Set_CUDA_Device_Entities): New internal subprogram.
+ * par-prag.adb (Prag): Handle pragma id Pragma_CUDA_Device.
+ * sem_prag.ads (Aspect_Specifying_Pragma): Mark CUDA_Device as
+ being both aspect and pragma.
+ * sem_prag.adb (Analyze_Pragma): Add CUDA_Device entities to
+ list of CUDA_Entities belonging to package N.
+ (Sig_Flags): Signal CUDA_Device entities as referenced.
+ * snames.ads-tmpl: Create CUDA_Device names and pragmas.
+
+2021-10-01 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb (Build_DIC_Procedure_Body): Remove inappropriate
+ Assert pragma. Remove unneeded and dead code related to derived
+ private types.
+
+2021-10-01 Richard Kenner <kenner@adacore.com>
+
+ * gen_il-gen-gen_nodes.adb (N_Alternative, N_Is_Case_Choice):
+ Add.
+ (N_Is_Exception_Choice, N_Is_Range): Likewise.
+ * gen_il-types.ads: Add above names.
+ * gen_il-gen.adb (Put_Union_Membership): Write both declarations
+ and definitions of union functions.
+
+2021-10-01 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Expand_Array_Aggregate,
+ Two_Pass_Aggregate_Expansion): Increment index for element
+ insertion within the loop, only if upper bound has not been
+ reached.
+
+2021-10-01 Javier Miranda <miranda@adacore.com>
+
+ * contracts.ads (Make_Class_Precondition_Subps): New subprogram.
+ (Merge_Class_Conditions): New subprogram.
+ (Process_Class_Conditions_At_Freeze_Point): New subprogram.
+ * contracts.adb (Check_Class_Condition): New subprogram.
+ (Set_Class_Condition): New subprogram.
+ (Analyze_Contracts): Remove code analyzing class-wide-clone
+ subprogram since it is no longer built.
+ (Process_Spec_Postconditions): Avoid processing twice seen
+ subprograms.
+ (Process_Preconditions): Simplify its functionality to
+ non-class-wide preconditions.
+ (Process_Preconditions_For): No action needed for wrappers and
+ helpers.
+ (Make_Class_Precondition_Subps): New subprogram.
+ (Process_Class_Conditions_At_Freeze_Point): New subprogram.
+ (Merge_Class_Conditions): New subprogram.
+ * exp_ch6.ads (Install_Class_Preconditions_Check): New
+ subprogram.
+ * exp_ch6.adb (Expand_Call_Helper): Install class-wide
+ preconditions check on dispatching primitives that have or
+ inherit class-wide preconditions.
+ (Freeze_Subprogram): Remove code for null procedures with
+ preconditions.
+ (Install_Class_Preconditions_Check): New subprogram.
+ * exp_util.ads (Build_Class_Wide_Expression): Lower the
+ complexity of this subprogram; out-mode formal Needs_Wrapper
+ since this functionality is now provided by a new subprogram.
+ (Get_Mapped_Entity): New subprogram.
+ (Map_Formals): New subprogram.
+ * exp_util.adb (Build_Class_Wide_Expression): Lower the
+ complexity of this subprogram. Its previous functionality is now
+ provided by subprograms Needs_Wrapper and Check_Class_Condition.
+ (Add_Parent_DICs): Map the overridden primitive to the
+ overriding one.
+ (Get_Mapped_Entity): New subprogram.
+ (Map_Formals): New subprogram.
+ (Update_Primitives_Mapping): Adding assertion.
+ * freeze.ads (Check_Inherited_Conditions): Subprogram made
+ public with added formal to support late overriding.
+ * freeze.adb (Check_Inherited_Conditions): New implementation;
+ builds the dispatch table wrapper required for class-wide
+ pre/postconditions; added support for late overriding.
+ (Needs_Wrapper): New subprogram.
+ * sem.ads (Inside_Class_Condition_Preanalysis): New global
+ variable.
+ * sem_disp.ads (Covered_Interface_Primitives): New subprogram.
+ * sem_disp.adb (Covered_Interface_Primitives): New subprogram.
+ (Check_Dispatching_Context): Skip checking context of
+ dispatching calls during preanalysis of class-wide conditions
+ since at that stage the expression is not installed yet on its
+ definite context.
+ (Check_Dispatching_Call): Skip checking 6.1.1(18.2/5) by
+ AI12-0412 on helpers and wrappers internally built for
+ supporting class-wide conditions; for late-overriding
+ subprograms call Check_Inherited_Conditions to build the
+ dispatch-table wrapper (if required).
+ (Propagate_Tag): Adding call to
+ Install_Class_Preconditions_Check.
+ * sem_util.ads (Build_Class_Wide_Clone_Body): Removed.
+ (Build_Class_Wide_Clone_Call): Removed.
+ (Build_Class_Wide_Clone_Decl): Removed.
+ (Class_Condition): New subprogram.
+ (Nearest_Class_Condition_Subprogram): New subprogram.
+ * sem_util.adb (Build_Class_Wide_Clone_Body): Removed.
+ (Build_Class_Wide_Clone_Call): Removed.
+ (Build_Class_Wide_Clone_Decl): Removed.
+ (Class_Condition): New subprogram.
+ (Nearest_Class_Condition_Subprogram): New subprogram.
+ (Eligible_For_Conditional_Evaluation): No need to evaluate
+ class-wide conditions during preanalysis since the expression is
+ not installed on its definite context.
+ * einfo.ads (Class_Wide_Clone): Removed.
+ (Class_Postconditions): New attribute.
+ (Class_Preconditions): New attribute.
+ (Class_Preconditions_Subprogram): New attribute.
+ (Dynamic_Call_Helper): New attribute.
+ (Ignored_Class_Postconditions): New attribute.
+ (Ignored_Class_Preconditions): New attribute.
+ (Indirect_Call_Wrapper): New attribute.
+ (Is_Dispatch_Table_Wrapper): New attribute.
+ (Static_Call_Helper): New attribute.
+ * exp_attr.adb (Expand_N_Attribute_Reference): When the prefix
+ is of an access-to-subprogram type that has class-wide
+ preconditions and an indirect-call wrapper of such subprogram is
+ available, replace the prefix by the wrapper.
+ * exp_ch3.adb (Build_Class_Condition_Subprograms): New
+ subprogram.
+ (Register_Dispatch_Table_Wrappers): New subprogram.
+ * exp_disp.adb (Build_Class_Wide_Check): Removed; class-wide
+ precondition checks now rely on internally built helpers.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Set initial
+ value of attributes Class_Preconditions, Class_Postconditions,
+ Ignored_Class_Preconditions and Ignored_Class_Postconditions.
+ These values are later updated with the full pre/postcondition
+ by Merge_Class_Conditions.
+ (Freeze_Entity_Checks): Call
+ Process_Class_Conditions_At_Freeze_Point.
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Remove code
+ building the body of the class-wide clone subprogram since it is
+ no longer required.
+ (Install_Entity): Adding assertion.
+ * sem_prag.adb (Analyze_Pre_Post_Condition_In_Decl_Part): Remove
+ code building and analyzing the class-wide clone subprogram; no
+ longer required.
+ (Build_Pragma_Check_Equivalent): Adjust call to
+ Build_Class_Wide_Expression since the formal named Needs_Wrapper
+ has been removed.
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Skip processing
+ these attributes during preanalysis of class-wide conditions
+ since at that stage the expression is not installed yet on its
+ definite context.
+ * sem_res.adb (Resolve_Actuals): Skip applying RM 3.9.2(9/1) and
+ SPARK RM 6.1.7(3) on actuals of internal helpers and wrappers
+ built to support class-wide preconditions.
+ * sem_ch5.adb (Process_Bounds): Do not generate a constant
+ declaration for the bounds when we are preanalyzing a class-wide
+ condition.
+ (Analyze_Loop_Parameter_Specification): Handle preanalysis of
+ quantified expression placed in the outermost expression of a
+ class-wide condition.
+ * ghost.adb (Check_Ghost_Context): No check required during
+ preanalysis of class-wide conditions.
+ * gen_il-fields.ads (Opt_Field_Enum): Adding
+ Class_Postconditions, Class_Preconditions,
+ Class_Preconditions_Subprogram, Dynamic_Call_Helper,
+ Ignored_Class_Postconditions, Ignored_Class_Preconditions,
+ Indirect_Call_Wrapper, Is_Dispatch_Table_Wrapper,
+ Static_Call_Helper.
+ * gen_il-gen-gen_entities.adb (Is_Dispatch_Table_Wrapper):
+ Adding semantic flag Is_Dispatch_Table_Wrapper; removing
+ semantic field Class_Wide_Clone; adding semantic fields for
+ Class_Postconditions, Class_Preconditions,
+ Class_Preconditions_Subprogram, Dynamic_Call_Helper,
+ Ignored_Class_Postconditions, Indirect_Call_Wrapper,
+ Ignored_Class_Preconditions, and Static_Call_Helper.
+
+2021-10-01 Piotr Trojanek <trojanek@adacore.com>
+
+ * comperr.adb (Delete_SCIL_Files): Handle generic subprogram
+ declarations and renaming just like generic package declarations
+ and renamings, respectively; handle
+ N_Subprogram_Renaming_Declaration.
+
+2021-10-01 Steve Baird <baird@adacore.com>
+
+ * bcheck.adb (Check_Versions): Add support for the case where
+ the .ali file contains both a primary and a secondary version
+ number, as in "GNAT Lib v22.20210809".
+
+2021-10-01 Steve Baird <baird@adacore.com>
+
+ * sem_res.adb (Resolve): Two separate fixes. In the case where
+ Find_Aspect for a literal aspect returns the aspect for a
+ different (ancestor) type, call Corresponding_Primitive_Op to
+ get the right callee. In the case where a downward tagged type
+ conversion appears to be needed, generate a null extension
+ aggregate instead, as per Ada RM 3.4(27).
+ * sem_util.ads, sem_util.adb: Add new Corresponding_Primitive_Op
+ function. It maps a primitive op of a tagged type and a
+ descendant type of that tagged type to the corresponding
+ primitive op of the descendant type. The body of this function
+ was written by Javier Miranda.
+
+2021-10-01 Bob Duff <duff@adacore.com>
+
+ * atree.adb: Gather and print statistics about frequency of
+ getter and setter calls.
+ * atree.ads (Print_Statistics): New procedure for printing
+ statistics.
+ * debug.adb: Document -gnatd.A switch.
+ * gen_il-gen.adb: Generate code for statistics gathering.
+ Choose the offset of Homonym early. Misc cleanup. Put more
+ comments in the generated code.
+ * gen_il-internals.ads (Unknown_Offset): New value to indicate
+ that the offset has not yet been chosen.
+ * gnat1drv.adb: Call Print_Statistics.
+ * libgnat/s-imglli.ads: Minor comment fix.
+ * output.ads (Write_Int_64): New procedure to write a 64-bit
+ value. Needed for new statistics, and could come in handy
+ elsewhere.
+ * output.adb (Write_Int_64): Likewise.
+ * sinfo.ads: Remove obsolete comment. The xtreeprs program no
+ longer exists.
+ * types.ads: New 64-bit types needed for new statistics.
+
+2021-10-01 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/memtrack.adb (Putc): New routine wrapped around fputc
+ with error check.
+ (Write): New routine wrapped around fwrite with error check.
+ Remove bound functions fopen, fwrite, fputs, fclose, OS_Exit.
+ Use the similar routines from System.CRTL and System.OS_Lib.
+
+2021-10-01 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Must_Slide): If the aggregate only contains an
+ others_clause no sliding id involved. Otherwise sliding is
+ required if any bound of the aggregate or the context subtype is
+ non-static.
+
+2021-10-01 Richard Kenner <kenner@adacore.com>
+
+ * gen_il-gen-gen_nodes.adb (N_Is_Decl): Add.
+ * gen_il-types.ads (N_Is_Decl): Likewise.
+
+2021-10-01 Richard Kenner <kenner@adacore.com>
+
+ * gen_il-gen-gen_nodes.adb (N_Entity_Name): Add.
+ * gen_il-types.ads (N_Entity_Name): Likewise.
+
+2021-10-01 Steve Baird <baird@adacore.com>
+
+ * bcheck.adb (Check_Versions): In the case of an ali file
+ version mismatch, if distinct integer values can be extracted
+ from the two version strings then include those values in the
+ generated error message.
+
+2021-10-01 Steve Baird <baird@adacore.com>
+
+ * sem_elab.adb (Is_Safe_Call): Return True in the case of a
+ (possibly rewritten) call to an expression function.
+
+2021-10-01 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_aggr.adb (Resolve_Iterated_Component_Association):
+ Initialize Id_Typ to Any_Type by default.
+
+2021-10-01 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_ugn/gnat_and_program_execution.rst (gnatmem): Document
+ that it works only with fixed-position executables.
+
+2021-10-01 Doug Rupp <rupp@adacore.com>
+
+ * libgnat/s-parame__vxworks.ads (time_t_bits): Change to
+ Long_Long_Integer'Size.
+
+2021-09-23 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Fix comment.
+
+2021-09-23 Richard Kenner <kenner@adacore.com>
+
+ * gen_il-gen-gen_entities.adb (Subprogram_Body_Or_Type): Add.
+ * gen_il-types.ads (Subprogram_Body_Or_Type): Likewise.
+
+2021-09-23 Richard Kenner <kenner@adacore.com>
+
+ * einfo-utils.adb (Next_Index): Verify input and output are
+ N_Is_Index.
+ * gen_il-gen-gen_nodes.adb (N_Has_Bounds, N_Is_Index): Add.
+ * gen_il-types.ads (N_Has_Bounds, N_Is_Index): Likewise.
+ * sem_ch3.adb (Array_Type_Declaration): Use Next, not
+ Next_Index.
+ * sem_ch12.adb (Formal_Dimensions): Likewise.
+ * sem_util.adb (Is_Valid_Renaming): Likewise.
+
+2021-09-23 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_ugn/gnat_utility_programs.rst (gnatsymbolize):
+ Document new --load option and -g1 as minimal compilation
+ requirement.
+
+2021-09-23 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Only keep the bounds
+ for internally generated attributes; otherwise, compute them
+ anew.
+
+2021-09-23 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Build_Access_Subprogram_Wrapper): Decorate the
+ wrapper with attribute Is_Wrapper, and move its declaration to
+ the freezing actions of its type declaration; done to facilitate
+ identifying it at later stages to avoid handling it as a
+ primitive operation of a tagged type; otherwise it may be
+ handled as a dispatching operation and erroneously registered in
+ a dispatch table.
+ (Make_Index): Add missing decoration of field Parent.
+ * sem_disp.adb (Check_Dispatching_Operation): Complete
+ decoration of late-overriding dispatching primitives.
+ (Is_Access_To_Subprogram_Wrapper): New subprogram.
+ (Inherited_Subprograms): Prevent cascaded errors; adding missing
+ support for private types.
+ * sem_type.adb (Add_One_Interp): Add missing support for the
+ first interpretation of a primitive of an inmediate ancestor
+ interface.
+ * sem_util.adb (Check_Result_And_Post_State_In_Pragma): Do not
+ report missing reference in postcondition placed in internally
+ built wrappers.
+ * exp_disp.adb (Expand_Dispatching_Call): Adding assertion.
+
+2021-09-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Check the validity of
+ an array aggregate all of whose components are iterated
+ component associations.
+ * exp_aggr.adb (Expand_Array_Aggregate,
+ Two_Pass_Aggregate_Expansion): implement two-pass algorithm and
+ replace original aggregate with resulting temporary, to ensure
+ that a proper length check is performed if context is
+ constrained. Use attributes Pos and Val to handle index types of
+ any discrete type.
+
+2021-09-23 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb: Set the number of concrete nodes that have the
+ Homonym field to a higher number than any other field. This
+ isn't true, but it forces Homonym's offset to be chosen first,
+ so it will be at offset zero and hence slot zero.
+
+2021-09-23 Richard Kenner <kenner@adacore.com>
+
+ * atree.adb (Relocate_Node): If relocating a subprgram call and
+ we're doing unnesting, make a new Parameter_Associations, if
+ any.
+
+2021-09-23 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/a-strbou.ads (Generic_Bounded_Length): Remove explicit
+ Initializes contract.
+
+2021-09-23 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb: Generate getters and setters with much of the
+ code inlined. Generate code for storing a few fields in the node
+ header, to avoid the extra level of indirection for those
+ fields. We generate the header type, so we don't have to
+ duplicate hand-written Ada and C code to depend on the number of
+ header fields. Declare constants for slot size. Use short names
+ because these are used all over. Remove
+ Put_Low_Level_Accessor_Instantiations, Put_Low_Level_C_Getter,
+ which are no longer needed. Rename
+ Put_High_Level_C_Getter-->Put_C_Getter.
+ * atree.ads, atree.adb: Take into account the header slots.
+ Take into account the single Node_Or_Entity_Field type. Remove
+ "pragma Assertion_Policy (Ignore);", because the routines in
+ this package are no longer efficiency critical.
+ * atree.h: Remove low-level getters, which are no longer used by
+ sinfo.h and einfo.h.
+ * einfo-utils.adb: Avoid crash in Known_Alignment.
+ * live.adb, sem_eval.adb: Remove code that prevents Node_Id from
+ having a predicate. We don't actually add a predicate to
+ Node_Id, but we want to be able to for temporary debugging.
+ * sinfo-utils.adb: Remove code that prevents Node_Id from having
+ a predicate. Take into account the single Node_Or_Entity_Field
+ type.
+ * sinfo-utils.ads: Minor.
+ * table.ads (Table_Type): Make the components aliased, because
+ low-level setters in Atree need to take 'Access.
+ * treepr.adb: Take into account the single Node_Or_Entity_Field
+ type. Make some code more robust, so we can print out
+ half-baked nodes.
+ * types.ads: Move types here for visibility purposes.
+ * gcc-interface/gigi.h, gcc-interface/trans.c: Take into account
+ the Node_Header change in the GNAT front end.
+ * gcc-interface/cuintp.c, gcc-interface/targtyps.c: Add because
+ gigi.h now refers to type Node_Header, which is in sinfo.h.
+
+2021-09-23 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-strfix.adb (Delete, Insert, Overwrite,
+ Replace_Slice): Remove SPARK_Mode Off.
+ * libgnat/a-strfix.ads (Insert, Overwrite, Replace_Slice):
+ Strengthen precondition.
+
+2021-09-23 Piotr Trojanek <trojanek@adacore.com>
+
+ * libgnat/a-strbou.ads (Generic_Bounded_Length): Remove non-null
+ Global contracts.
+
+2021-09-23 Steve Baird <baird@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_characteristics.rst: Update
+ this section to reflect the current version of Ada RM M.2.
+ * gnat_rm.texi: Regenerate.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-strfix.ads (Trim): Simplify contracts.
+ * libgnat/a-strfix.adb (Trim): Remove white space.
+
+2021-09-22 Piotr Trojanek <trojanek@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Eq): Reuse Is_Attribute_Result.
+ * exp_prag.adb (Expand_Attributes): Reuse Is_Attribute_Old.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Do not insert a
+ predicate check after a deferred constant declaration.
+
+2021-09-22 Bob Duff <duff@adacore.com>
+
+ * contracts.adb, einfo-utils.adb, einfo-utils.ads, exp_ch7.adb,
+ exp_ch9.adb, exp_disp.adb, exp_prag.adb, exp_smem.adb,
+ exp_util.adb, freeze.adb, sem_aggr.adb, sem_attr.adb,
+ sem_ch8.adb, sem_prag.ads, sem_util.adb, sem_util.ads: Fix
+ conformance errors.
+ * errout.adb, erroutc.adb: Remove pragmas Suppress.
+ * err_vars.ads: Initialize variables that were previously being
+ read uninitialized.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * libgnat/a-strunb.ads: Mark package in SPARK with private part
+ not in SPARK.
+ (Free): Mark not in SPARK.
+
+2021-09-22 Arnaud Charlet <charlet@adacore.com>
+
+ * snames.ads-tmpl: Update status of some attributes.
+
+2021-09-22 Doug Rupp <rupp@adacore.com>
+
+ * libgnarl/s-interr__vxworks.adb (Interfaces.C): Remove as
+ unused.
+ (System.VxWorks.Ext): Import.
+ (System.VxWorks.Ext.STATUS): use type.
+ (STATUS): New subtype.
+ (OK): New constant.
+ (Interrupt_Connector): Return STATUS type vice int.
+ (Interrupt_Connect, Notify_Interrupt, Unbind_Handler,
+ Interrupt_Server_Task): Rename Status to Result. Assert Result =
+ OK.
+ * libgnarl/s-osinte__vxworks.adb (To_Clock_Ticks): Define constant
+ IERR, and return it vice ERROR.
+ (Binary_Semaphore_Delete): Return STATUS type vice int.
+ (Binary_Semaphore_Obtain): Likewise.
+ (Binary_Semaphore_Release): Likewise.
+ (Binary_Semaphore_Flush): Likewise.
+ * libgnarl/s-osinte__vxworks.ads (SVE): Renaming of
+ System.VxWorks.Ext.
+ (STATUS): Use SVE in declaration of subtype.
+ (BOOL): Likewise.
+ (vx_freq_t): Likewise.
+ (t_id): Likewise.
+ (gitpid): Use SVE in renaming of subprogram
+ (Task_Stop): Likewise.
+ (Task_Cont): Likewise.
+ (Int_Lock): Likewise.
+ (Int_Unlock): Likewise.
+ (Set_Time_Slice): Likewise.
+ (semDelete): Likewise.
+ (taskCpuAffinitySet): Likewise.
+ (taskMaskAffinitySet): Likewise.
+ (sigset_t): Use SVE in declaration of type.
+ (OK): Remove as unused.
+ (ERROR): Likewise.
+ (taskOptionsGet): return STATUS vice int.
+ (taskSuspend): Likewise.
+ (taskResume): Likewise.
+ (taskDelay): Likewise.
+ (taskVarAdd): Likewise.
+ (taskVarDelete): Likewise.
+ (taskVarSet): Likewise.
+ (tlkKeyCreate): Likewise.
+ (taskPrioritySet): Likewise.
+ (semGive): Likewise.
+ (semTake): Likewise.
+ (Binary_Semaphore_Delete): Likewise.
+ (Binary_Semaphore_Obtain): Likewise.
+ (Binary_Semaphore_Release): Likewise.
+ (Binary_Semaphore_Flush): Likewise.
+ (Interrupt_Connect): Likewise.
+ * libgnarl/s-taprop__vxworks.adb
+ (System.VxWorks.Ext.STATUS): use type.
+ (int): Syntactically align subtype.
+ (STATUS): New subtype.
+ (OK): New constant.
+ (Finalize_Lock): Check STATUS vice int. Assert OK.
+ (Finalize_Lock): Likewise.
+ (Write_Lock): Likewise.
+ (Write_Lock): Likewise.
+ (Write_Lock): Likewise.
+ (Unlock): Likewise.
+ (Unlock): Likewise.
+ (Unlock): Likewise.
+ (Unlock): Likewise.
+ (Sleep): Likewise.
+ (Sleep): Likewise.
+ (Sleep): Likewise.
+ (Timed_Sleep): Likewise and test Result.
+ (Timed_Delay): Likewise and test Result.
+ (Wakeup): Likewise.
+ (Yield): Likewise.
+ (Finalize_TCB): Likewise.
+ (Suspend_Until_True): Check OK.
+ (Stop_All_Tasks): Declare Dummy STATUS vice in. Check OK.
+ (Is_Task_Context): Use OSI renaming.
+ (Initialize): Use STATUS vice int.
+ * libgnarl/s-vxwext.adb
+ (IERR): Renamed from ERROR.
+ (taskCpuAffinitySet): Return IERR (int).
+ (taskMaskAffinitySet): Likewise.
+ * libgnarl/s-vxwext.ads
+ (STATUS): New subtype.
+ (OK): New STATUS constant.
+ (ERROR): Likewise.
+ * libgnarl/s-vxwext__kernel-smp.adb
+ (IERR): Renamed from ERROR.
+ (Int_Lock): Return IERR.
+ (semDelete): Return STATUS.
+ (Task_Cont): Likewise.
+ (Task_Stop): Likewise.
+ * libgnarl/s-vxwext__kernel.adb
+ (IERR): Renamed from ERROR.
+ (semDelete): Return STATUS.
+ (Task_Cont): Likewise.
+ (Task_Stop): Likewise.
+ (taskCpuAffinitySet): Return IERR (int)
+ (taskMaskAffinitySet): Likewise.
+ * libgnarl/s-vxwext__kernel.ads
+ (STATUS): New subtype.
+ (OK): New STATUS constant.
+ (ERROR): Likewise.
+ (Interrupt_Connect): Return STATUS
+ (semDelete): Likewise.
+ (Task_Cont): Likewise.
+ (Task_Stop): Likewise.
+ (Set_Time_Slice): Likewise.
+ * libgnarl/s-vxwext__rtp-smp.adb
+ (IERR): Renamed from ERROR.
+ (Int_Lock): return IERR constant vice ERROR.
+ (Interrupt_Connect): Return STATUS.
+ (semDelete): Likewise.
+ (Set_Time_Slice): Likewise.
+ * libgnarl/s-vxwext__rtp.adb
+ (IERR): Renamed from ERROR.
+ (Int_Lock): return IERR constant vice ERROR.
+ (Int_Unlock): Return STATUS.
+ (semDelete): Likewise.
+ (Set_Time_Slice): Likewise.
+ (taskCpuAffinitySet): Return IERR (int)
+ (taskMaskAffinitySet): Likewise.
+ * libgnarl/s-vxwext__rtp.ads
+ (STATUS): New subtype.
+ (OK): New STATUS constant.
+ (ERROR): Likewise.
+ (Interrupt_Connect): Return STATUS
+ (semDelete): Likewise.
+ (Task_Cont): Likewise.
+ (Task_Stop): Likewise.
+ (Set_Time_Slice): Likewise.
+
+2021-09-22 Arnaud Charlet <charlet@adacore.com>
+
+ * prep.adb (Preprocess): Allow for more flexibility when
+ Relaxed_RM_Semantics is set.
+
+2021-09-22 Pierre-Alexandre Bazin <bazin@adacore.com>
+
+ * libgnat/a-strbou.adb: Turn SPARK_Mode on.
+ * libgnat/a-strbou.ads: Write contracts.
+ * libgnat/a-strfix.ads (Index): Fix grammar error in a comment.
+ * libgnat/a-strsea.ads (Index): Likewise.
+ * libgnat/a-strsup.adb: Rewrite the body to take into account
+ the new definition of Super_String using Relaxed_Initialization
+ and a predicate.
+ (Super_Replicate, Super_Translate, Times): Added loop
+ invariants, and ghost lemmas for Super_Replicate and Times.
+ (Super_Trim): Rewrite the body using search functions to
+ determine the cutting points.
+ (Super_Element, Super_Length, Super_Slice, Super_To_String):
+ Remove (now written as expression functions in a-strsup.ads).
+ * libgnat/a-strsup.ads: Added contracts.
+ (Super_Element, Super_Length, Super_Slice, Super_To_String):
+ Rewrite as expression functions.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * sem_ch13.adb (Build_Predicate_Functions): Add guard.
+
+2021-09-22 Doug Rupp <rupp@adacore.com>
+
+ * libgnarl/s-vxwext.ads (BOOL): New int type.
+ (Interrupt_Context): Change return type to BOOL.
+ * libgnarl/s-vxwext__kernel.ads: Likewise.
+ * libgnarl/s-vxwext__rtp-smp.adb: Likewise.
+ * libgnarl/s-vxwext__rtp.adb: Likewise.
+ * libgnarl/s-vxwext__rtp.ads: Likewise.
+ * libgnarl/s-osinte__vxworks.adb (Interrupt_Context): Change
+ return type to BOOL.
+ * libgnarl/s-osinte__vxworks.ads (BOOL) New subtype.
+ (taskIsSuspended): Change return type to BOOL.
+ (Interrupt_Context): Change return type to BOOL. Adjust comments
+ accordingly.
+ * libgnarl/s-taprop__vxworks.adb (System.VxWorks.Ext.BOOL):
+ use type.
+ (Is_Task_Context): Test Interrupt_Context against 0.
+ * libgnat/i-vxwork.ads (BOOL): New int.
+ (intContext): Change return type to BOOL. Adjust comments.
+ * libgnat/i-vxwork__x86.ads: Likewise.
+
+2021-09-22 Piotr Trojanek <trojanek@adacore.com>
+
+ * sem_aux.adb, sem_aux.ads (Package_Body): Moved from GNATprove.
+ * sem_elab.adb (Spec_And_Body_From_Entity): Refine type of parameter.
+
+2021-09-22 Arnaud Charlet <charlet@adacore.com>
+
+ * doc/gnat_ugn/platform_specific_information.rst: Improve doc
+ on permission and containers.
+ * gnat_ugn.texi: Regenerate.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * atree.adb (Rewrite): Fix parent node of shared aspects.
+ * atree.ads (Rewrite): Add ??? comment on incorrect
+ documentation.
+ * einfo-utils.adb (Known_Esize): Fix logic.
+ * sem_ch13.adb (Alignment_Check_For_Size_Change,
+ Analyze_Attribute_Definition_Clause): Protect against unset
+ Size.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * freeze.adb (Build_Renamed_Body): Special case for GNATprove.
+ * sem_ch6.adb (Analyze_Expression_Function): Remove useless test
+ for a node to come from source, which becomes harmful otherwise.
+
+2021-09-22 Justin Squirek <squirek@adacore.com>
+
+ * ali.adb, ali.ads (Scan_ALI): Remove use of deprecated
+ parameter Ignore_ED, and all specification for Lower in call to
+ Get_File_Name.
+ * ali-util.adb (Read_Withed_ALIs): Modify call to Scan_ALI.
+ * clean.adb (Clean_Executables): Likewise.
+ * gnatbind.adb (Add_Artificial_ALI_File, Executable section):
+ Likewise.
+ * gnatlink.adb (Executable section): Likewise.
+ * gnatls.adb (Executable section): Likewise.
+ * make.adb (Check, Wait_For_Available_Slot): Likewise.
+ * aspects.ads: Add Aspect_No_Controlled_Parts to
+ Nonoverridable_Aspect_Id
+ * opt.ads: Remove function pointers used as a workaround for
+ ASIS.
+ * osint-c.adb (Executable section): Remove setting of function
+ pointer workarounds needed for ASIS.
+ * osint.adb (Read_Default_Search_Dirs): Correct behavior to
+ detect EOL characters.
+ * par_sco.adb (Output_Header): Remove comment regarding use of
+ First_Sloc.
+ (Traverse_Sync_Definition): Renamed to
+ Traverse_Protected_Or_Task_Definition.
+ * pprint.adb (Interal_List_Name): Add description about purpose,
+ and refactor conditional statement.
+ (Prepend): Removed.
+ * repinfo.adb (List_Rep_Info, Write_Info_Line): Remove use of
+ subprogram pointer.
+ * scng.adb (Scan): Remove CODEFIX question, and minor comment
+ change.
+ * sem_attr.adb (Analyze_Image_Attribute): Remove special
+ processing for 'Img.
+ * sem_ch6.adb (Check_Untagged_Equality): Add RM reference.
+ (FCE): Add comment describing behavior.
+ (Is_Non_Overriding_Operation): Minor comment formatting change.
+ * sem_type.adb (Is_Actual_Subprogram): Add comment about
+ Comes_From_Source test.
+ (Matching_Types): Describe non-matching cases.
+ * sem_util.adb (Is_Confirming): Add stub case for
+ No_Controlled_Parts.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * sem_ch13.adb (Build_Predicate_Functions): Access
+ Predicated_Parent only on subtypes.
+
+2021-09-22 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Process_Import_Or_Interface): Relax error when
+ Relaxed_RM_Semantics.
+
+2021-09-22 Steve Baird <baird@adacore.com>
+
+ * libgnat/s-regpat.adb (Match): Handle the case where Self.First
+ is not NUL (so we know the first character we are looking for),
+ but case-insensitive matching has
+ been specified.
+ (Optimize): In the case of an EXACTF Op, set Self.First as is
+ done in the EXACT case, except with the addition of a call to
+ Lower_Case.
+
+2021-09-22 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-imenne.ads, libgnat/s-imenne.adb: Delete.
+ * gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Remove s-imenne.o.
+ (GNATBIND_OBJS): Likewise.
+
+2021-09-22 Yannick Moy <moy@adacore.com>
+
+ * einfo.ads: Fix comments.
+ * exp_aggr.adb: Fix variable name.
+ * exp_util.adb: Fix comments.
+ * sem_ch13.adb: Fix comments.
+ * sem_ch3.adb: Fix comments and variable name.
+
+2021-09-22 Doug Rupp <rupp@adacore.com>
+
+ * libgnarl/s-osinte__vxworks.ads: Make procedure vice function.
+ * libgnarl/s-vxwext.ads: Likewise.
+ * libgnarl/s-vxwext__kernel-smp.adb: Likewise.
+ * libgnarl/s-vxwext__kernel.adb: Likewise.
+ * libgnarl/s-vxwext__kernel.ads: Likewise.
+ * libgnarl/s-vxwext__rtp-smp.adb: Likewise.
+ * libgnarl/s-vxwext__rtp.adb: Likewise.
+ * libgnarl/s-vxwext__rtp.ads: Likewise.
+ * libgnarl/s-taprop__vxworks.adb (Stop_All_Tasks): Call
+ Int_Unlock as a procedure.
+
+2021-09-22 Doug Rupp <rupp@adacore.com>
+
+ * libgnarl/s-osinte__vxworks.ads (SVE): New package renaming
+ (vx_freq_t): New subtype.
+ (sysClkRateGet): Return vx_freq_t.
+ * libgnarl/s-vxwext.ads (vx_freq_t): New type.
+ * libgnarl/s-vxwext__kernel.ads: Likewise.
+ * libgnarl/s-vxwext__rtp.ads: Likewise.
+
+2021-09-22 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_case.adb (Composite_Case_Ops): Replace 'Image with
+ Error_Msg_Uint.
+
+2021-09-22 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_If_Expression): Generate an intermediate
+ temporary when the expression is a condition in an outer decision
+ and control-flow optimizations are suppressed.
+
+2021-09-22 Steve Baird <baird@adacore.com>
+
+ * exp_ch5.adb (Expand_General_Case_Statement.Pattern_Match): Add
+ new function Indexed_Element to handle array element
+ comparisons. Handle case choices that are array aggregates,
+ string literals, or names denoting constants.
+ * sem_case.adb (Composite_Case_Ops.Array_Case_Ops): New package
+ providing utilities needed for casing on arrays.
+ (Composite_Case_Ops.Choice_Analysis): If necessary, include
+ array length as a "component" (like a discriminant) when
+ traversing components. We do not (yet) partition choice analysis
+ to deal with unequal length choices separately. Instead, we
+ embed everything in the minimum-dimensionality Cartesian product
+ space needed to handle all choices properly; this is determined
+ by the length of the longest choice pattern.
+ (Composite_Case_Ops.Choice_Analysis.Traverse_Discrete_Parts):
+ Include length as a "component" in the traversal if necessary.
+ (Composite_Case_Ops.Choice_Analysis.Parse_Choice.Traverse_Choice):
+ Add support for case choices that are string literals or names
+ denoting constants.
+ (Composite_Case_Ops.Choice_Analysis): Include length as a
+ "component" in the analysis if necessary.
+ (Check_Choices.Check_Case_Pattern_Choices.Ops.Value_Sets.Value_Index_Count):
+ Improve error message when capacity exceeded.
+ * doc/gnat_rm/implementation_defined_pragmas.rst: Update
+ documentation to reflect current implementation status.
+ * gnat_rm.texi: Regenerate.
+
+2021-09-22 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Check_Component_Storage_Order): Give a specific error
+ message for non-byte-aligned component in the packed case. Replace
+ "composite" with "record" in both cases.
+
+2021-09-22 Arnaud Charlet <charlet@adacore.com>
+
+ * libgnarl/a-tasini.ads, libgnarl/a-tasini.adb: Make compatible
+ with No_Elaboration_Code_All.
+ * libgnarl/s-taskin.ads, libgnarl/s-tassta.adb: Adjust
+ accordingly.
+
+2021-09-22 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Check_Returns): Change message on missing return.
+
+2021-09-22 Arnaud Charlet <charlet@adacore.com>
+
+ * gnatfind.adb, gnatxref.adb: Mark these tools as obsolete
+ before removing them completely.
+
+2021-09-22 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (range_cannot_be_superflat): Tweak comments.
+
+2021-09-21 Doug Rupp <rupp@adacore.com>
+
+ * init.c (__gnat_error_handler) [LynxOS]: Add a comment about
+ missing optional args.
+
+2021-09-21 Yannick Moy <moy@adacore.com>
+
+ * gen_il-gen.adb (Put_Opt_Subtype): Add suffix.
+
+2021-09-21 Justin Squirek <squirek@adacore.com>
+
+ * sem_util.adb (Accessibility_Level): Remove spurious special
+ case for protected type components.
+ * exp_ch4.adb (Generate_Accessibility_Check): Use general
+ Accessibility_Level instead of the low-level function
+ Type_Access_Level.
+
+2021-09-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnat_ugn.texi: Regenerate.
+
+2021-09-21 Matthieu Eyraud <eyraud@adacore.com>
+
+ * par_sco.adb (Traverse_One): Add support for pragma Invariant /
+ Type_Invariant.
+
+2021-09-21 Bob Duff <duff@adacore.com>
+
+ * gen_il-gen.adb (Put_Opt_Subtype): Print out subtypes of the
+ form:
+ subtype Opt_N_Declaration is
+ Node_Id with Predicate =>
+ Opt_N_Declaration = Empty or else
+ Opt_N_Declaration in N_Declaration_Id;
+ One for each node or entity type, with the predicate allowing
+ Empty.
+ * atree.adb (Parent, Set_Parent): Remove unnecessary "Atree.".
+
+2021-09-21 Patrick Bernardi <bernardi@adacore.com>
+
+ * bindgen.adb (Gen_Adainit): For targets that suppress the
+ standard library: set the default stack size global variable if
+ a value is provided via the -d switch, and generate a call to
+ __gnat_initialize_stack_limit if stack checking using stack
+ limits is enabled.
+
+2021-09-21 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb (Stream_Size): Print message about allowed stream
+ sizes even if other error were already found. This avoids
+ falling into the 'else', which prints "Stream_Size cannot be
+ given for...", which is misleading -- the Size COULD be given if
+ it were correct.
+
+2021-09-21 Daniel Mercier <mercier@adacore.com>
+
+ * exp_util.adb (Build_Temporary): In case of an external DISCR
+ symbol, set the related expression for CodePeer so that a more
+ comprehensible message can be emitted to the user.
+
+2021-09-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-dwalin.adb (Parse_Header): Tweak comments.
+ (Read_Entry_Format_Array): Tweak exception message.
+ (Symbolic_Address.Set_Result): Likewise.
+
+2021-09-21 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch7.adb (Make_Init_Call): Add guard to protect against a
+ missing initialization procedure for a type.
+
+2021-09-21 Doug Rupp <rupp@adacore.com>
+
+ * Makefile.rtl: Remove unused VxWorks sections.
+ * libgnarl/s-vxwext__noints.adb: Remove.
+ * libgnarl/s-vxwext__vthreads.ads: Remove.
+ * libgnat/a-elchha__vxworks-ppc-full.adb: Remove.
+ * libgnat/s-osprim__vxworks.adb: Remove.
+ * libgnat/s-osvers__vxworks-653.ads: Remove.
+ * libgnat/system-vxworks-e500-vthread.ads: Remove.
+ * libgnat/system-vxworks-ppc-vthread.ads: Remove.
+ * libgnat/system-vxworks-x86-vthread.ads: Remove.
+
+2021-09-21 Bob Duff <duff@adacore.com>
+
+ * uintp.ads, uintp.adb (UI_Is_In_Int_Range): Change the type of
+ the formal parameter to Valid_Uint. Remove code that preserved
+ the previous behavior, and replace it with an assertion. The
+ previous behavior is no longer needed given the recent change to
+ gigi.
+ (No, Present): Add comment.
+
+2021-09-21 Bob Duff <duff@adacore.com>
+
+ * sem_eval.adb (Fold_Shift): Replace an if_expression with an
+ if_statement.
+
+2021-09-21 Bob Duff <duff@adacore.com>
+
+ * uintp.ads, uintp.adb: Add assertions.
+ (Ubool, Opt_Ubool): New "boolean" subtypes.
+ (UI_Is_In_Int_Range): The parameter should probably be
+ Valid_Uint, but we don't change that for now, because it causes
+ failures in gigi.
+ * sem_util.ads, sem_util.adb (Is_True, Is_False,
+ Static_Boolean): Use Opt_Ubool subtype. Document the fact that
+ Is_True (No_Uint) = True. Implement Is_False in terms of
+ Is_True. We considered changing Static_Boolean to return Uint_1
+ in case of error, but that doesn't fit in well with
+ Static_Integer.
+ (Has_Compatible_Alignment_Internal): Deal with cases where Offs
+ is No_Uint. Change one "and" to "and then" to ensure we don't
+ pass No_Uint to ">", which would violate the new assertions.
+ * exp_util.adb, freeze.adb, sem_ch13.adb: Avoid violating new
+ assertions in Uintp.
+
+2021-09-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-dwalin.adb (To_File_Name): Fetch only the last string
+ from the .debug_line_str section.
+ (Symbolic_Address.Set_Result): Likewise.
+
+2021-09-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * libgnat/s-dwalin.adb (Skip_Form): Fix cases of DW_FORM_addrx
+ and DW_FORM_implicit_const. Replace Constraint_Error with
+ Dwarf_Error.
+
+2021-09-21 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * exp_pakd.adb (Expand_Packed_Not): Replace expression with
+ statement.
+
+2021-09-21 Ghjuvan Lacambre <lacambre@adacore.com>
+
+ * sem_eval.adb (Is_Static_Subtype): Take predicates created
+ through "predicate" pragma into account.
+
+2021-09-21 Frederic Konrad <konrad@adacore.com>
+
+ * Makefile.rtl (aarch64-rtems*): Add GNATRTL_128BIT_PAIRS to
+ the LIBGNAT_TARGET_PAIRS list and also GNATRTL_128BIT_OBJS to
+ the EXTRA_GNATRTL_NONTASKING_OBJS list.
+
+2021-09-21 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch4.adb (Remove_Abstract_Operations): Add condition to
+ test for an E_Operator as part of criteria for setting
+ Abstract_Op on interpretations involving predefined operators.
+
+2021-09-21 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Expand_Simple_Function_Return): For explicit
+ dereference of type conversion, enable code that ensures that
+ the tag of the result is that of the result type.
+
+2021-09-21 Bob Duff <duff@adacore.com>
+
+ * einfo-utils.adb: Add support (currently disabled) for using
+ "initial zero" instead of "Uint_0" to represent "unknown". Call
+ Known_ functions, instead of evilly duplicating their code
+ inline.
+ * fe.h (No_Uint_To_0): New function to convert No_Uint to
+ Uint_0, in order to preserve existing behavior.
+ (Copy_Esize, Copy_RM_Size): New imports from Einfo.Utils.
+ * cstand.adb: Set size fields of Standard_Debug_Renaming_Type
+ and Standard_Exception_Type.
+ * checks.adb, exp_attr.adb, exp_ch3.adb, exp_ch5.adb,
+ exp_ch6.adb, exp_pakd.adb, exp_util.adb, freeze.adb, itypes.adb,
+ layout.adb, repinfo.adb, sem_attr.adb, sem_ch12.adb,
+ sem_ch13.adb, sem_ch13.ads, sem_ch3.adb, sem_ch7.adb,
+ sem_util.adb: Protect calls with Known_..., use Copy_... Remove
+ assumption that Uint_0 represents "unknown".
+ * types.ads (Nonzero_Int): New subtype.
+ * gcc-interface/decl.c, gcc-interface/trans.c: Protect calls
+ with Known_... and use Copy_... as appropriate, to avoid
+ blowing up in unknown cases. Similarly, call No_Uint_To_0 to
+ preserve existing behavior.
+
+2021-09-21 Steve Baird <baird@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Add a new nested
+ function, Directly_Specified, and then use it in the
+ implementation of the required check.
+
+2021-09-21 Steve Baird <baird@adacore.com>
+
+ * libgnat/a-costso.ads, libgnat/a-costso.adb: A new library
+ unit, Ada.Containers.Stable_Sorting, which exports a pair of
+ generics (one within the other) which are instantiated by each
+ of the 5 doubly-linked list container generics to implement
+ their respective Sort procedures. We use a pair of generics,
+ rather than a single generic, in order to further reduce code
+ duplication. The outer generic takes a formal private Node_Ref
+ type representing a reference to a linked list element. For some
+ instances, the corresponding actual parameter will be an access
+ type; for others, it will be the index type for an array.
+ * Makefile.rtl: Include new Ada.Containers.Stable_Sorting unit.
+ * libgnat/a-cbdlli.adb, libgnat/a-cdlili.adb,
+ libgnat/a-cfdlli.adb, libgnat/a-cidlli.adb, libgnat/a-crdlli.adb
+ (Sort): Replace existing Sort implementation with a call to an
+ instance of
+ Ada.Containers.Stable_Sorting.Doubly_Linked_List_Sort. Declare
+ the (trivial) actual parameters needed to declare that instance.
+ * libgnat/a-cfdlli.ads: Fix a bug encountered during testing in
+ the postcondition for M_Elements_Sorted. With a partial
+ ordering, it is possible for all three of (X < Y), (Y < X),
+ and (X = Y) to be simultaneously false, so that case needs to
+ handled correctly.
+
+2021-09-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * errout.adb (Error_Msg_Internal): Fix references to Sptr and
+ Optr in comment; fix grammar of "low-level" where it is used as
+ an adjective.
+
+2021-09-21 Piotr Trojanek <trojanek@adacore.com>
+
+ * errout.adb (Write_Source_Code_Lines): Use Cur_Loc before
+ incrementing it, so that we don't need to decrement it.
+
+2021-09-21 Yannick Moy <moy@adacore.com>
+
+ * errout.adb (Get_Line_End): Do not allow the result to go past
+ the end of the buffer.
+
+2021-09-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Process_Discriminant_Expressions): If the
+ constraint is for a Component_Definition that appears in a
+ Component_Declaration, the entity to be used to create the
+ potentially global symbol is the Defining_Identifier of the
+ Component_Declaration.
+
+2021-09-21 Bob Duff <duff@adacore.com>
+
+ * libgnat/a-stbufi.ads, libgnat/a-stbufi.adb: Change all
+ occurrences of GNAT.OS_Lib to System.OS_Lib.
+
2021-09-20 Piotr Trojanek <trojanek@adacore.com>
* inline.adb (Has_Excluded_Declaration): Remove redundant guard;
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index d4445f0..60cfa93 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -98,6 +98,7 @@
#ifdef __QNX__
#include <sys/syspage.h>
+#include <sys/time.h>
#endif
#ifdef IN_RTS
diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb
index 9074a9a..6c567c3 100644
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -249,7 +249,6 @@
Scan_ALI
(F => Afile,
T => Text,
- Ignore_ED => False,
Err => False);
Free (Text);
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index 24f1677..3815a70 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -892,7 +892,6 @@
function Scan_ALI
(F : File_Name_Type;
T : Text_Buffer_Ptr;
- Ignore_ED : Boolean;
Err : Boolean;
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False;
@@ -1319,8 +1318,7 @@
exit when Nextc = ',';
-- Terminate if left bracket not part of wide char
- -- sequence Note that we only recognize brackets
- -- notation so far ???
+ -- sequence.
exit when Nextc = '[' and then T (P + 1) /= '"';
@@ -2938,9 +2936,7 @@
-- Store AD indication unless ignore required
- if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_All_Desirable := True;
- end if;
+ Withs.Table (Withs.Last).Elab_All_Desirable := True;
elsif Nextc = 'E' then
P := P + 1;
@@ -2957,12 +2953,9 @@
Checkc ('D');
Check_At_End_Of_Field;
- -- Store ED indication unless ignore required
+ -- Store ED indication
- if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_Desirable :=
- True;
- end if;
+ Withs.Table (Withs.Last).Elab_Desirable := True;
end if;
else
@@ -3213,13 +3206,10 @@
Skip_Space;
Sdep.Increment_Last;
- -- In the following call, Lower is not set to True, this is either
- -- a bug, or it deserves a special comment as to why this is so???
-
-- The file/path name may be quoted
Sdep.Table (Sdep.Last).Sfile :=
- Get_File_Name (May_Be_Quoted => True);
+ Get_File_Name (Lower => True, May_Be_Quoted => True);
Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
Sdep.Table (Sdep.Last).Dummy_Entry :=
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 3ac9f0e..175aea9 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -1389,7 +1389,6 @@
function Scan_ALI
(F : File_Name_Type;
T : Text_Buffer_Ptr;
- Ignore_ED : Boolean;
Err : Boolean;
Ignore_Lines : String := "X";
Ignore_Errors : Boolean := False;
@@ -1399,11 +1398,6 @@
-- table. Switch settings may be modified as described above in the
-- switch description settings.
--
- -- Ignore_ED is normally False. If set to True, it indicates that
- -- all AD/ED (elaboration desirable) indications in the ALI file are
- -- to be ignored. This parameter is obsolete now that the -f switch
- -- is removed from gnatbind, and should be removed ???
- --
-- Err determines the action taken on an incorrectly formatted file.
-- If Err is False, then an error message is output, and the program
-- is terminated. If Err is True, then no error message is output,
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 0f9ed23..ab11bfd 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -89,6 +89,7 @@
Aspect_Default_Storage_Pool,
Aspect_Default_Value,
Aspect_Depends, -- GNAT
+ Aspect_Designated_Storage_Model, -- GNAT
Aspect_Dimension, -- GNAT
Aspect_Dimension_System, -- GNAT
Aspect_Dispatching_Domain,
@@ -147,6 +148,7 @@
Aspect_SPARK_Mode, -- GNAT
Aspect_Stable_Properties,
Aspect_Static_Predicate,
+ Aspect_Storage_Model_Type, -- GNAT
Aspect_Storage_Pool,
Aspect_Storage_Size,
Aspect_Stream_Size,
@@ -187,6 +189,7 @@
Aspect_Atomic_Components,
Aspect_Disable_Controlled, -- GNAT
Aspect_Discard_Names,
+ Aspect_CUDA_Device, -- GNAT
Aspect_CUDA_Global, -- GNAT
Aspect_Exclusive_Functions,
Aspect_Export,
@@ -233,7 +236,7 @@
Aspect_Implicit_Dereference | Aspect_Constant_Indexing |
Aspect_Variable_Indexing | Aspect_Aggregate |
Aspect_Max_Entry_Queue_Length
- -- | Aspect_No_Controlled_Parts
+ | Aspect_No_Controlled_Parts
-- ??? No_Controlled_Parts not yet in Aspect_Id enumeration
; -- see RM 13.1.1(18.7)
@@ -379,6 +382,7 @@
Aspect_Default_Storage_Pool => Expression,
Aspect_Default_Value => Expression,
Aspect_Depends => Expression,
+ Aspect_Designated_Storage_Model => Name,
Aspect_Dimension => Expression,
Aspect_Dimension_System => Expression,
Aspect_Dispatching_Domain => Expression,
@@ -437,6 +441,7 @@
Aspect_SPARK_Mode => Optional_Name,
Aspect_Stable_Properties => Expression,
Aspect_Static_Predicate => Expression,
+ Aspect_Storage_Model_Type => Expression,
Aspect_Storage_Pool => Name,
Aspect_Storage_Size => Expression,
Aspect_Stream_Size => Expression,
@@ -476,6 +481,7 @@
Aspect_Contract_Cases => False,
Aspect_Convention => True,
Aspect_CPU => False,
+ Aspect_CUDA_Device => False,
Aspect_CUDA_Global => False,
Aspect_Default_Component_Value => True,
Aspect_Default_Initial_Condition => False,
@@ -483,6 +489,7 @@
Aspect_Default_Storage_Pool => True,
Aspect_Default_Value => True,
Aspect_Depends => False,
+ Aspect_Designated_Storage_Model => True,
Aspect_Dimension => False,
Aspect_Dimension_System => False,
Aspect_Dispatching_Domain => False,
@@ -542,6 +549,7 @@
Aspect_SPARK_Mode => False,
Aspect_Stable_Properties => False,
Aspect_Static_Predicate => False,
+ Aspect_Storage_Model_Type => False,
Aspect_Storage_Pool => True,
Aspect_Storage_Size => True,
Aspect_Stream_Size => True,
@@ -627,6 +635,7 @@
Aspect_Contract_Cases => Name_Contract_Cases,
Aspect_Convention => Name_Convention,
Aspect_CPU => Name_CPU,
+ Aspect_CUDA_Device => Name_CUDA_Device,
Aspect_CUDA_Global => Name_CUDA_Global,
Aspect_Default_Component_Value => Name_Default_Component_Value,
Aspect_Default_Initial_Condition => Name_Default_Initial_Condition,
@@ -634,6 +643,7 @@
Aspect_Default_Storage_Pool => Name_Default_Storage_Pool,
Aspect_Default_Value => Name_Default_Value,
Aspect_Depends => Name_Depends,
+ Aspect_Designated_Storage_Model => Name_Designated_Storage_Model,
Aspect_Dimension => Name_Dimension,
Aspect_Dimension_System => Name_Dimension_System,
Aspect_Disable_Controlled => Name_Disable_Controlled,
@@ -723,6 +733,7 @@
Aspect_Stable_Properties => Name_Stable_Properties,
Aspect_Static => Name_Static,
Aspect_Static_Predicate => Name_Static_Predicate,
+ Aspect_Storage_Model_Type => Name_Storage_Model_Type,
Aspect_Storage_Pool => Name_Storage_Pool,
Aspect_Storage_Size => Name_Storage_Size,
Aspect_Stream_Size => Name_Stream_Size,
@@ -872,11 +883,13 @@
Aspect_Attach_Handler => Always_Delay,
Aspect_Constant_Indexing => Always_Delay,
Aspect_CPU => Always_Delay,
+ Aspect_CUDA_Device => Always_Delay,
Aspect_CUDA_Global => Always_Delay,
Aspect_Default_Iterator => Always_Delay,
Aspect_Default_Storage_Pool => Always_Delay,
Aspect_Default_Value => Always_Delay,
Aspect_Default_Component_Value => Always_Delay,
+ Aspect_Designated_Storage_Model => Always_Delay,
Aspect_Discard_Names => Always_Delay,
Aspect_Dispatching_Domain => Always_Delay,
Aspect_Dynamic_Predicate => Always_Delay,
@@ -928,6 +941,7 @@
Aspect_Simple_Storage_Pool => Always_Delay,
Aspect_Simple_Storage_Pool_Type => Always_Delay,
Aspect_Static_Predicate => Always_Delay,
+ Aspect_Storage_Model_Type => Always_Delay,
Aspect_Storage_Pool => Always_Delay,
Aspect_Stream_Size => Always_Delay,
Aspect_String_Literal => Always_Delay,
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 540d4ff..98614e8 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -23,20 +23,12 @@
-- --
------------------------------------------------------------------------------
--- Assertions in this package are too slow, and are mostly needed when working
--- on this package itself, or on gen_il, so we disable them.
--- To debug low-level bugs in this area, comment out the following pragma,
--- and run with -gnatd_v.
-
-pragma Assertion_Policy (Ignore);
-
with Aspects; use Aspects;
with Debug; use Debug;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
-with Seinfo; use Seinfo;
with Sinfo.Utils; use Sinfo.Utils;
with System.Storage_Elements;
@@ -153,7 +145,11 @@
function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count;
-- Number of slots belonging to N. This can be less than
- -- Size_In_Slots_To_Alloc for entities.
+ -- Size_In_Slots_To_Alloc for entities. Includes both header
+ -- and dynamic slots.
+
+ function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count;
+ -- Just counts the number of dynamic slots
function Size_In_Slots_To_Alloc (N : Node_Or_Entity_Id) return Slot_Count;
function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count;
@@ -161,35 +157,47 @@
-- to allocate the max, because we don't know the Ekind when this is
-- called.
- function Off_0 (N : Node_Id) return Node_Offset;
- -- Offset of the first slot of N (offset 0) in Slots.Table
+ function Off_F (N : Node_Id) return Node_Offset with Inline;
+ -- Offset of the first dynamic slot of N in Slots.Table.
+ -- The actual offset of this slot from the start of the node
+ -- is not 0; this is logically the first slot after the header
+ -- slots.
- function Off_L (N : Node_Id) return Node_Offset;
+ function Off_0 (N : Node_Id) return Node_Offset'Base with Inline;
+ -- This is for zero-origin addressing of the dynamic slots.
+ -- It points to slot 0 of N in Slots.Table, which does not exist,
+ -- because the first few slots are stored in the header.
+
+ function Off_L (N : Node_Id) return Node_Offset with Inline;
-- Offset of the last slot of N in Slots.Table
- procedure Zero_Slots (First, Last : Node_Offset) with Inline;
- -- Set slots in the range F..L to zero
+ procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) with Inline;
+ -- Set dynamic slots in the range First..Last to zero
+
+ procedure Zero_Header_Slots (N : Node_Or_Entity_Id) with Inline;
+ -- Zero the header slots belonging to N
procedure Zero_Slots (N : Node_Or_Entity_Id) with Inline;
- -- Zero the slots belonging to N
+ -- Zero the slots belonging to N (both header and dynamic)
- procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count)
+ procedure Copy_Dynamic_Slots
+ (From, To : Node_Offset; Num_Slots : Slot_Count)
with Inline;
-- Copy Num_Slots slots from From to To. Caller is responsible for ensuring
-- that the Num_Slots at To are a reasonable place to copy to.
procedure Copy_Slots (Source, Destination : Node_Id) with Inline;
- -- Copies the slots of Source to Destination; uses the node kind to
- -- determine the Num_Slots.
+ -- Copies the slots (both header and dynamic) of Source to Destination;
+ -- uses the node kind to determine the Num_Slots.
function Get_Field_Value
- (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit;
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit;
-- Get any field value as a Field_Size_32_Bit. If the field is smaller than
-- 32 bits, convert it to Field_Size_32_Bit. The Field must be present in
-- the Nkind of N.
procedure Set_Field_Value
- (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit);
+ (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit);
-- Set any field value as a Field_Size_32_Bit. If the field is smaller than
-- 32 bits, convert it from Field_Size_32_Bit, and Val had better be small
-- enough. The Field must be present in the Nkind of N.
@@ -199,10 +207,6 @@
-- Called whenever Nkind is modified. Raises an exception if not all
-- vanishing fields are in their initial zero state.
- function Get_Field_Value
- (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit;
- procedure Set_Field_Value
- (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit);
procedure Check_Vanishing_Fields
(Old_N : Entity_Id; New_Kind : Entity_Kind);
-- Above are the same as the ones for nodes, but for entities
@@ -405,7 +409,8 @@
pragma Assert (N'Valid);
pragma Assert (N <= Node_Offsets.Last);
- pragma Assert (Off_0 (N) <= Off_L (N));
+ pragma Assert (Off_L (N) >= Off_0 (N));
+ pragma Assert (Off_L (N) >= Off_F (N) - 1);
pragma Assert (Off_L (N) <= Slots.Last);
pragma Assert (Nkind (N)'Valid);
pragma Assert (Nkind (N) /= N_Unused_At_End);
@@ -469,8 +474,9 @@
function Cast is new
Unchecked_Conversion (Field_Size_1_Bit, Field_Type);
+ Val : constant Field_Size_1_Bit := Get_1_Bit_Val (N, Offset);
begin
- return Cast (Get_1_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_1_Bit_Field;
function Get_2_Bit_Field
@@ -480,8 +486,9 @@
function Cast is new
Unchecked_Conversion (Field_Size_2_Bit, Field_Type);
+ Val : constant Field_Size_2_Bit := Get_2_Bit_Val (N, Offset);
begin
- return Cast (Get_2_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_2_Bit_Field;
function Get_4_Bit_Field
@@ -491,8 +498,9 @@
function Cast is new
Unchecked_Conversion (Field_Size_4_Bit, Field_Type);
+ Val : constant Field_Size_4_Bit := Get_4_Bit_Val (N, Offset);
begin
- return Cast (Get_4_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_4_Bit_Field;
function Get_8_Bit_Field
@@ -502,8 +510,9 @@
function Cast is new
Unchecked_Conversion (Field_Size_8_Bit, Field_Type);
+ Val : constant Field_Size_8_Bit := Get_8_Bit_Val (N, Offset);
begin
- return Cast (Get_8_Bit_Val (N, Offset));
+ return Cast (Val);
end Get_8_Bit_Field;
function Get_32_Bit_Field
@@ -514,7 +523,8 @@
function Cast is new
Unchecked_Conversion (Field_Size_32_Bit, Field_Type);
- Result : constant Field_Type := Cast (Get_32_Bit_Val (N, Offset));
+ Val : constant Field_Size_32_Bit := Get_32_Bit_Val (N, Offset);
+ Result : constant Field_Type := Cast (Val);
-- Note: declaring Result here instead of directly returning
-- Cast (...) helps CodePeer understand that there are no issues
-- around uninitialized variables.
@@ -612,138 +622,228 @@
Set_32_Bit_Val (N, Offset, Cast (Val));
end Set_32_Bit_Field;
+ pragma Style_Checks ("M90");
+
+ -----------------------------------
+ -- Low-level getters and setters --
+ -----------------------------------
+
+ -- In the getters and setters below, we use shifting and masking to
+ -- simulate packed arrays. F_Size is the field size in bits. Mask is
+ -- that number of 1 bits in the low-order bits. F_Per_Slot is the number
+ -- of fields per slot. Slot_Off is the offset of the slot of interest.
+ -- S is the slot at that offset. V is the amount to shift by.
+
+ function In_NH (Slot_Off : Field_Offset) return Boolean is
+ (Slot_Off < N_Head);
+ -- In_NH stands for "in Node_Header", not "in New Hampshire"
+
+ function Get_Slot
+ (N : Node_Or_Entity_Id; Slot_Off : Field_Offset)
+ return Slot is
+ (if In_NH (Slot_Off) then
+ Node_Offsets.Table (N).Slots (Slot_Off)
+ else Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off));
+ -- Get the slot value, either directly from the node header, or
+ -- indirectly from the Slots table.
+
+ procedure Set_Slot
+ (N : Node_Or_Entity_Id; Slot_Off : Field_Offset; S : Slot);
+ -- Set the slot value, either directly from the node header, or
+ -- indirectly from the Slots table, to S.
+
function Get_1_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_1_Bit
is
- -- We wish we were using packed arrays, but instead we're simulating
- -- them with modular integers. L here (and elsewhere) is the 'Length
- -- of that simulated array.
- L : constant Field_Offset := Slot_Size / 1;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 1;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_1_Bit :=
+ Field_Size_1_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_1_Bit (Shift_Right (S, V) and 1);
+ return Raw;
end Get_1_Bit_Val;
function Get_2_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_2_Bit
is
- L : constant Field_Offset := Slot_Size / 2;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 2;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_2_Bit :=
+ Field_Size_2_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_2_Bit (Shift_Right (S, V) and 3);
+ return Raw;
end Get_2_Bit_Val;
function Get_4_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_4_Bit
is
- L : constant Field_Offset := Slot_Size / 4;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 4;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_4_Bit :=
+ Field_Size_4_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_4_Bit (Shift_Right (S, V) and 15);
+ return Raw;
end Get_4_Bit_Val;
function Get_8_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_8_Bit
is
- L : constant Field_Offset := Slot_Size / 8;
-
- pragma Debug (Validate_Node_And_Offset (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 8;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_8_Bit :=
+ Field_Size_8_Bit (Shift_Right (S, V) and Mask);
begin
- return Field_Size_8_Bit (Shift_Right (S, V) and 255);
+ return Raw;
end Get_8_Bit_Val;
function Get_32_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Size_32_Bit
is
- pragma Debug (Validate_Node_And_Offset (N, Offset));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
+ F_Size : constant := 32;
+ -- No Mask needed
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ pragma Debug (Validate_Node_And_Offset (N, Slot_Off));
+ Raw : constant Field_Size_32_Bit :=
+ Field_Size_32_Bit (S);
begin
- return Field_Size_32_Bit (S);
+ return Raw;
end Get_32_Bit_Val;
+ procedure Set_Slot
+ (N : Node_Or_Entity_Id; Slot_Off : Field_Offset; S : Slot) is
+ begin
+ if In_NH (Slot_Off) then
+ Node_Offsets.Table (N).Slots (Slot_Off) := S;
+ else
+ Slots.Table (Node_Offsets.Table (N).Offset + Slot_Off) := S;
+ end if;
+ end Set_Slot;
+
procedure Set_1_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_1_Bit)
is
- L : constant Field_Offset := Slot_Size / 1;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 1;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (1, V)) or Shift_Left (Slot (Val), V);
+ Set_Slot
+ (N, Slot_Off,
+ (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V));
end Set_1_Bit_Val;
procedure Set_2_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_2_Bit)
is
- L : constant Field_Offset := Slot_Size / 2;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 2;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (3, V)) or Shift_Left (Slot (Val), V);
+ Set_Slot
+ (N, Slot_Off,
+ (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V));
end Set_2_Bit_Val;
procedure Set_4_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_4_Bit)
is
- L : constant Field_Offset := Slot_Size / 4;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 4;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (15, V)) or Shift_Left (Slot (Val), V);
+ Set_Slot
+ (N, Slot_Off,
+ (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V));
end Set_4_Bit_Val;
procedure Set_8_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_8_Bit)
is
- L : constant Field_Offset := Slot_Size / 8;
-
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
- V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
+ F_Size : constant := 8;
+ Mask : constant := 2**F_Size - 1;
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ S : constant Slot := Get_Slot (N, Slot_Off);
+ V : constant Natural := Natural ((Offset mod F_Per_Slot) * F_Size);
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := (S and not Shift_Left (255, V)) or Shift_Left (Slot (Val), V);
+ Set_Slot
+ (N, Slot_Off,
+ (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Val), V));
end Set_8_Bit_Val;
procedure Set_32_Bit_Val
(N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Size_32_Bit)
is
- pragma Debug (Validate_Node_And_Offset_Write (N, Offset));
-
- S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
+ F_Size : constant := 32;
+ -- No Mask needed; this one doesn't do read-modify-write
+ F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;
+ Slot_Off : constant Field_Offset := Offset / F_Per_Slot;
+ pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));
begin
- S := Slot (Val);
+ Set_Slot (N, Slot_Off, Slot (Val));
end Set_32_Bit_Val;
+ ----------------------
+ -- Print_Atree_Info --
+ ----------------------
+
+ procedure Print_Atree_Info (N : Node_Or_Entity_Id) is
+ function Cast is new Unchecked_Conversion (Slot, Int);
+ begin
+ Write_Int (Int (Size_In_Slots (N)));
+ Write_Str (" slots (");
+ Write_Int (Int (Off_0 (N)));
+ Write_Str (" .. ");
+ Write_Int (Int (Off_L (N)));
+ Write_Str ("):");
+
+ for Off in Off_0 (N) .. Off_L (N) loop
+ Write_Str (" ");
+ Write_Int (Cast (Get_Slot (N, Off)));
+ end loop;
+
+ Write_Eol;
+ end Print_Atree_Info;
+
end Atree_Private_Part;
- ---------------
- -- Set_Field --
- ---------------
+ ---------------------
+ -- Get_Field_Value --
+ ---------------------
function Get_Node_Field_Union is new Get_32_Bit_Field (Union_Id)
with Inline;
@@ -751,10 +851,9 @@
-- etc.
function Get_Field_Value
- (N : Node_Id; Field : Node_Field) return Field_Size_32_Bit
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Field_Size_32_Bit
is
- pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
- Desc : Field_Descriptor renames Node_Field_Descriptors (Field);
+ Desc : Field_Descriptor renames Field_Descriptors (Field);
begin
case Field_Size (Desc.Kind) is
@@ -766,11 +865,14 @@
end case;
end Get_Field_Value;
+ ---------------------
+ -- Set_Field_Value --
+ ---------------------
+
procedure Set_Field_Value
- (N : Node_Id; Field : Node_Field; Val : Field_Size_32_Bit)
+ (N : Node_Id; Field : Node_Or_Entity_Field; Val : Field_Size_32_Bit)
is
- pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
- Desc : Field_Descriptor renames Node_Field_Descriptors (Field);
+ Desc : Field_Descriptor renames Field_Descriptors (Field);
begin
case Field_Size (Desc.Kind) is
@@ -782,13 +884,15 @@
end case;
end Set_Field_Value;
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field) is
+ procedure Reinit_Field_To_Zero
+ (N : Node_Id; Field : Node_Or_Entity_Field)
+ is
begin
Set_Field_Value (N, Field, 0);
end Reinit_Field_To_Zero;
function Field_Is_Initial_Zero
- (N : Node_Id; Field : Node_Field) return Boolean is
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Boolean is
begin
return Get_Field_Value (N, Field) = 0;
end Field_Is_Initial_Zero;
@@ -814,7 +918,7 @@
Old_Kind : constant Node_Kind := Nkind (Old_N);
-- If this fails, it means you need to call Reinit_Field_To_Zero before
- -- calling Set_Nkind.
+ -- calling Mutate_Nkind.
begin
for J in Node_Field_Table (Old_Kind)'Range loop
@@ -839,47 +943,6 @@
end loop;
end Check_Vanishing_Fields;
- function Get_Field_Value
- (N : Entity_Id; Field : Entity_Field) return Field_Size_32_Bit
- is
- pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
- Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
- begin
- case Field_Size (Desc.Kind) is
- when 1 => return Field_Size_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
- when 2 => return Field_Size_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
- when 4 => return Field_Size_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
- when 8 => return Field_Size_32_Bit (Get_8_Bit_Val (N, Desc.Offset));
- when others => return Get_32_Bit_Val (N, Desc.Offset); -- 32
- end case;
- end Get_Field_Value;
-
- procedure Set_Field_Value
- (N : Entity_Id; Field : Entity_Field; Val : Field_Size_32_Bit)
- is
- pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
- Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
- begin
- case Field_Size (Desc.Kind) is
- when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_Size_1_Bit (Val));
- when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_Size_2_Bit (Val));
- when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_Size_4_Bit (Val));
- when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_Size_8_Bit (Val));
- when others => Set_32_Bit_Val (N, Desc.Offset, Val); -- 32
- end case;
- end Set_Field_Value;
-
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field) is
- begin
- Set_Field_Value (N, Field, 0);
- end Reinit_Field_To_Zero;
-
- function Field_Is_Initial_Zero
- (N : Entity_Id; Field : Entity_Field) return Boolean is
- begin
- return Get_Field_Value (N, Field) = 0;
- end Field_Is_Initial_Zero;
-
procedure Check_Vanishing_Fields
(Old_N : Entity_Id; New_Kind : Entity_Kind)
is
@@ -918,13 +981,17 @@
end Check_Vanishing_Fields;
Nkind_Offset : constant Field_Offset :=
- Node_Field_Descriptors (F_Nkind).Offset;
+ Field_Descriptors (F_Nkind).Offset;
procedure Set_Node_Kind_Type is new Set_8_Bit_Field (Node_Kind) with Inline;
procedure Init_Nkind (N : Node_Id; Val : Node_Kind) is
pragma Assert (Field_Is_Initial_Zero (N, F_Nkind));
begin
+ if Atree_Statistics_Enabled then
+ Set_Count (F_Nkind) := Set_Count (F_Nkind) + 1;
+ end if;
+
Set_Node_Kind_Type (N, Nkind_Offset, Val);
end Init_Nkind;
@@ -943,35 +1010,47 @@
if Old_Size < New_Size then
declare
Old_Last_Slot : constant Node_Offset := Slots.Last;
- Old_Off_0 : constant Node_Offset := Off_0 (N);
+ Old_Off_F : constant Node_Offset := Off_F (N);
begin
- if Old_Last_Slot = Old_Off_0 + Old_Size - 1 then
+ if Old_Last_Slot = Old_Off_F + Old_Size - 1 then
-- In this case, the slots are at the end of Slots.Table, so we
-- don't need to move them.
Slots.Set_Last (Old_Last_Slot + New_Size - Old_Size);
else
-- Move the slots
- All_Node_Offsets (N) := Alloc_Slots (New_Size);
- Copy_Slots (Old_Off_0, Off_0 (N), Old_Size);
- pragma Debug (Zero_Slots (Old_Off_0, Old_Off_0 + Old_Size - 1));
+
+ declare
+ New_Off_F : constant Node_Offset := Alloc_Slots (New_Size);
+ begin
+ All_Node_Offsets (N).Offset := New_Off_F - N_Head;
+ Copy_Dynamic_Slots (Old_Off_F, New_Off_F, Old_Size);
+ pragma Debug
+ (Zero_Dynamic_Slots (Old_Off_F, Old_Off_F + Old_Size - 1));
+ end;
end if;
end;
- Zero_Slots (Off_0 (N) + Old_Size, Slots.Last);
+ Zero_Dynamic_Slots (Off_F (N) + Old_Size, Slots.Last);
+ end if;
+
+ if Atree_Statistics_Enabled then
+ Set_Count (F_Nkind) := Set_Count (F_Nkind) + 1;
end if;
Set_Node_Kind_Type (N, Nkind_Offset, Val);
pragma Debug (Validate_Node_Write (N));
+
+ New_Node_Debugging_Output (N);
end Mutate_Nkind;
procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) is
begin
- Mutate_Nkind (N, Val, Old_Size => Size_In_Slots (N));
+ Mutate_Nkind (N, Val, Old_Size => Size_In_Slots_Dynamic (N));
end Mutate_Nkind;
Ekind_Offset : constant Field_Offset :=
- Entity_Field_Descriptors (F_Ekind).Offset;
+ Field_Descriptors (F_Ekind).Offset;
procedure Set_Entity_Kind_Type is new Set_8_Bit_Field (Entity_Kind)
with Inline;
@@ -991,8 +1070,14 @@
-- For now, we are allocating all entities with the same size, so we
-- don't need to reallocate slots here.
+ if Atree_Statistics_Enabled then
+ Set_Count (F_Nkind) := Set_Count (F_Ekind) + 1;
+ end if;
+
Set_Entity_Kind_Type (N, Ekind_Offset, Val);
pragma Debug (Validate_Node_Write (N));
+
+ New_Node_Debugging_Output (N);
end Mutate_Ekind;
-----------------------
@@ -1006,8 +1091,9 @@
Sz : constant Slot_Count := Size_In_Slots_To_Alloc (Kind);
Sl : constant Node_Offset := Alloc_Slots (Sz);
begin
- Node_Offsets.Table (Result) := Sl;
- Zero_Slots (Sl, Sl + Sz - 1);
+ Node_Offsets.Table (Result).Offset := Sl - N_Head;
+ Zero_Dynamic_Slots (Sl, Sl + Sz - 1);
+ Zero_Header_Slots (Result);
end;
Init_Nkind (Result, Kind);
@@ -1045,7 +1131,7 @@
pragma Assert (Nkind (N) not in N_Entity);
pragma Assert (New_Kind not in N_Entity);
- Old_Size : constant Slot_Count := Size_In_Slots (N);
+ Old_Size : constant Slot_Count := Size_In_Slots_Dynamic (N);
New_Size : constant Slot_Count := Size_In_Slots_To_Alloc (New_Kind);
Save_Sloc : constant Source_Ptr := Sloc (N);
@@ -1068,15 +1154,16 @@
New_Offset : constant Field_Offset := Alloc_Slots (New_Size);
begin
pragma Debug (Zero_Slots (N));
- Node_Offsets.Table (N) := New_Offset;
- Zero_Slots (New_Offset, New_Offset + New_Size - 1);
+ Node_Offsets.Table (N).Offset := New_Offset - N_Head;
+ Zero_Dynamic_Slots (New_Offset, New_Offset + New_Size - 1);
+ Zero_Header_Slots (N);
end;
else
Zero_Slots (N);
end if;
- Mutate_Nkind (N, New_Kind, Old_Size);
+ Init_Nkind (N, New_Kind); -- Not Mutate, because of Zero_Slots above
Set_Sloc (N, Save_Sloc);
Set_In_List (N, Save_In_List);
@@ -1095,8 +1182,10 @@
-- Copy_Slots --
----------------
- procedure Copy_Slots (From, To : Node_Offset; Num_Slots : Slot_Count) is
- pragma Assert (From /= To);
+ procedure Copy_Dynamic_Slots
+ (From, To : Node_Offset; Num_Slots : Slot_Count)
+ is
+ pragma Assert (if Num_Slots /= 0 then From /= To);
All_Slots : Slots.Table_Type renames
Slots.Table (Slots.First .. Slots.Last);
@@ -1109,21 +1198,21 @@
begin
Destination_Slots := Source_Slots;
- end Copy_Slots;
+ end Copy_Dynamic_Slots;
procedure Copy_Slots (Source, Destination : Node_Id) is
pragma Debug (Validate_Node (Source));
- pragma Debug (Validate_Node_Write (Destination));
pragma Assert (Source /= Destination);
- S_Size : constant Slot_Count := Size_In_Slots (Source);
+ S_Size : constant Slot_Count := Size_In_Slots_Dynamic (Source);
All_Node_Offsets : Node_Offsets.Table_Type renames
Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
begin
- Copy_Slots
- (All_Node_Offsets (Source), All_Node_Offsets (Destination), S_Size);
+ Copy_Dynamic_Slots
+ (Off_F (Source), Off_F (Destination), S_Size);
+ All_Node_Offsets (Destination).Slots := All_Node_Offsets (Source).Slots;
end Copy_Slots;
---------------
@@ -1152,14 +1241,14 @@
if D_Size < S_Size then
pragma Debug (Zero_Slots (Destination)); -- destroy old slots
- Node_Offsets.Table (Destination) := Alloc_Slots (S_Size);
+ Node_Offsets.Table (Destination).Offset :=
+ Alloc_Slots (S_Size) - N_Head;
end if;
Copy_Slots (Source, Destination);
Set_In_List (Destination, Save_In_List);
Set_Link (Destination, Save_Link);
-
Set_Paren_Count_Of_Copy (Target => Destination, Source => Source);
end Copy_Node;
@@ -1371,7 +1460,7 @@
(Is_Entity (E1) and then Is_Entity (E2)
and then not In_List (E1) and then not In_List (E2));
- Old_E1 : constant Node_Offset := Node_Offsets.Table (E1);
+ Old_E1 : constant Node_Header := Node_Offsets.Table (E1);
begin
Node_Offsets.Table (E1) := Node_Offsets.Table (E2);
@@ -1404,6 +1493,7 @@
pragma Assert (not Is_Entity (Source));
Old_Kind : constant Node_Kind := Nkind (Source);
+ pragma Assert (Old_Kind in N_Direct_Name);
New_Kind : constant Node_Kind :=
(case Old_Kind is
when N_Character_Literal => N_Defining_Character_Literal,
@@ -1469,8 +1559,7 @@
begin
for J in Fields'Range loop
declare
- Desc : Field_Descriptor renames
- Node_Field_Descriptors (Fields (J));
+ Desc : Field_Descriptor renames Field_Descriptors (Fields (J));
begin
if Desc.Kind in Node_Id_Field | List_Id_Field then
Fix_Parent (Get_Node_Field_Union (Fix_Node, Desc.Offset));
@@ -1620,7 +1709,8 @@
end if;
return New_Id : constant Node_Id := Alloc_Node_Id do
- Node_Offsets.Table (New_Id) := Alloc_Slots (S_Size);
+ Node_Offsets.Table (New_Id).Offset :=
+ Alloc_Slots (S_Size) - N_Head;
Orig_Nodes.Append (New_Id);
Copy_Slots (Source, New_Id);
@@ -1676,7 +1766,7 @@
-- source nodes, then reset Current_Error_Node. This is useful
-- if we bomb during parsing to get a error location for the bomb.
- if New_Sloc > No_Location and then Comes_From_Source_Default then
+ if New_Sloc > No_Location and then Comes_From_Source_Default then
Current_Error_Node := New_Id;
end if;
@@ -1765,16 +1855,25 @@
-- Off_0 --
-----------
- function Off_0 (N : Node_Id) return Node_Offset is
+ function Off_0 (N : Node_Id) return Node_Offset'Base is
pragma Debug (Validate_Node (N));
All_Node_Offsets : Node_Offsets.Table_Type renames
Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
begin
- return All_Node_Offsets (N);
+ return All_Node_Offsets (N).Offset;
end Off_0;
-----------
+ -- Off_F --
+ -----------
+
+ function Off_F (N : Node_Id) return Node_Offset is
+ begin
+ return Off_0 (N) + N_Head;
+ end Off_F;
+
+ -----------
-- Off_L --
-----------
@@ -1784,7 +1883,7 @@
All_Node_Offsets : Node_Offsets.Table_Type renames
Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
begin
- return All_Node_Offsets (N) + Size_In_Slots (N) - 1;
+ return All_Node_Offsets (N).Offset + Size_In_Slots (N) - 1;
end Off_L;
-------------------
@@ -1794,6 +1893,9 @@
function Original_Node (Node : Node_Id) return Node_Id is
begin
pragma Debug (Validate_Node (Node));
+ if Atree_Statistics_Enabled then
+ Get_Original_Node_Count := Get_Original_Node_Count + 1;
+ end if;
return Orig_Nodes.Table (Node);
end Original_Node;
@@ -1855,28 +1957,6 @@
Set_Comes_From_Source (NewN, Comes_From_Source (OldN));
end Preserve_Comes_From_Source;
- ----------------------
- -- Print_Atree_Info --
- ----------------------
-
- procedure Print_Atree_Info (N : Node_Or_Entity_Id) is
- function Cast is new Unchecked_Conversion (Slot, Int);
- begin
- Write_Int (Int (Size_In_Slots (N)));
- Write_Str (" slots (");
- Write_Int (Int (Off_0 (N)));
- Write_Str (" .. ");
- Write_Int (Int (Off_L (N)));
- Write_Str ("):");
-
- for Off in Off_0 (N) .. Off_L (N) loop
- Write_Str (" ");
- Write_Int (Cast (Slots.Table (Off)));
- end loop;
-
- Write_Eol;
- end Print_Atree_Info;
-
-------------------
-- Relocate_Node --
-------------------
@@ -1908,6 +1988,22 @@
Set_Original_Node (New_Node, Original_Node (Source));
end if;
+ -- If we're relocating a subprogram call and we're doing
+ -- unnesting, be sure we make a new copy of any parameter associations
+ -- so that we don't share them.
+
+ if Nkind (Source) in N_Subprogram_Call
+ and then Opt.Unnest_Subprogram_Mode
+ and then Present (Parameter_Associations (Source))
+ then
+ declare
+ New_Assoc : constant List_Id := Parameter_Associations (Source);
+ begin
+ Set_Parent (New_Assoc, New_Node);
+ Set_Parameter_Associations (New_Node, New_Assoc);
+ end;
+ end if;
+
return New_Node;
end Relocate_Node;
@@ -1926,7 +2022,7 @@
procedure Destroy_New_Node is
begin
Zero_Slots (New_Node);
- Node_Offsets.Table (New_Node) := Field_Offset'Base'Last;
+ Node_Offsets.Table (New_Node).Offset := Field_Offset'Base'Last;
end Destroy_New_Node;
begin
@@ -2025,10 +2121,16 @@
-- Both the old and new copies of the node will share the same list
-- of aspect specifications if aspect specifications are present.
+ -- Restore the parent link of the aspect list to the old node, which
+ -- is the one linked in the tree.
if Old_Has_Aspects then
- Set_Aspect_Specifications
- (Sav_Node, Aspect_Specifications (Old_Node));
+ declare
+ Aspects : constant List_Id := Aspect_Specifications (Old_Node);
+ begin
+ Set_Aspect_Specifications (Sav_Node, Aspects);
+ Set_Parent (Aspects, Old_Node);
+ end;
end if;
end if;
@@ -2089,6 +2191,9 @@
procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
begin
pragma Debug (Validate_Node_Write (N));
+ if Atree_Statistics_Enabled then
+ Set_Original_Node_Count := Set_Original_Node_Count + 1;
+ end if;
Orig_Nodes.Table (N) := Val;
end Set_Original_Node;
@@ -2176,11 +2281,15 @@
Rewriting_Proc := Proc;
end Set_Rewriting_Proc;
+ ----------------------------
+ -- Size_In_Slots_To_Alloc --
+ ----------------------------
+
function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Slot_Count is
begin
return
(if Kind in N_Entity then Einfo.Entities.Max_Entity_Size
- else Sinfo.Nodes.Size (Kind));
+ else Sinfo.Nodes.Size (Kind)) - N_Head;
-- Unfortunately, we don't know the Entity_Kind, so we have to use the
-- max.
end Size_In_Slots_To_Alloc;
@@ -2191,6 +2300,10 @@
return Size_In_Slots_To_Alloc (Nkind (N));
end Size_In_Slots_To_Alloc;
+ -------------------
+ -- Size_In_Slots --
+ -------------------
+
function Size_In_Slots (N : Node_Or_Entity_Id) return Slot_Count is
begin
pragma Assert (Nkind (N) /= N_Unused_At_Start);
@@ -2199,6 +2312,15 @@
else Sinfo.Nodes.Size (Nkind (N)));
end Size_In_Slots;
+ ---------------------------
+ -- Size_In_Slots_Dynamic --
+ ---------------------------
+
+ function Size_In_Slots_Dynamic (N : Node_Or_Entity_Id) return Slot_Count is
+ begin
+ return Size_In_Slots (N) - N_Head;
+ end Size_In_Slots_Dynamic;
+
-------------------
-- Traverse_Func --
-------------------
@@ -2366,14 +2488,179 @@
-- Zero_Slots --
----------------
- procedure Zero_Slots (First, Last : Node_Offset) is
+ procedure Zero_Dynamic_Slots (First, Last : Node_Offset'Base) is
begin
Slots.Table (First .. Last) := (others => 0);
- end Zero_Slots;
+ end Zero_Dynamic_Slots;
+
+ procedure Zero_Header_Slots (N : Node_Or_Entity_Id) is
+ All_Node_Offsets : Node_Offsets.Table_Type renames
+ Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
+ begin
+ All_Node_Offsets (N).Slots := (others => 0);
+ end Zero_Header_Slots;
procedure Zero_Slots (N : Node_Or_Entity_Id) is
begin
- Zero_Slots (Off_0 (N), Off_L (N));
+ Zero_Dynamic_Slots (Off_F (N), Off_L (N));
+ Zero_Header_Slots (N);
end Zero_Slots;
+ ----------------------
+ -- Print_Statistics --
+ ----------------------
+
+ procedure Print_Node_Statistics;
+ procedure Print_Field_Statistics;
+ -- Helpers for Print_Statistics
+
+ procedure Write_Ratio (X : Nat_64; Y : Pos_64);
+ -- Write the value of (X/Y) without using 'Image (approximately)
+
+ procedure Write_Ratio (X : Nat_64; Y : Pos_64) is
+ pragma Assert (X <= Y);
+ Ratio : constant Nat := Nat ((Long_Float (X) / Long_Float (Y)) * 1000.0);
+ begin
+ Write_Str (" (");
+
+ if Ratio = 0 then
+ Write_Str ("0.000");
+ elsif Ratio in 1 .. 9 then
+ Write_Str ("0.00");
+ Write_Int (Ratio);
+ elsif Ratio in 10 .. 99 then
+ Write_Str ("0.0");
+ Write_Int (Ratio);
+ elsif Ratio in 100 .. 999 then
+ Write_Str ("0.");
+ Write_Int (Ratio);
+ else
+ Write_Int (Ratio / 1000);
+ end if;
+
+ Write_Str (")");
+ end Write_Ratio;
+
+ procedure Print_Node_Statistics is
+ subtype Count is Nat_64;
+ Node_Counts : array (Node_Kind) of Count := (others => 0);
+ Entity_Counts : array (Entity_Kind) of Count := (others => 0);
+
+ All_Node_Offsets : Node_Offsets.Table_Type renames
+ Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
+ begin
+ Write_Int (Int (Node_Offsets.Last));
+ Write_Line (" nodes (including entities)");
+ Write_Int (Int (Slots.Last));
+ Write_Line (" non-header slots");
+
+ for N in All_Node_Offsets'Range loop
+ declare
+ K : constant Node_Kind := Nkind (N);
+
+ begin
+ Node_Counts (K) := Node_Counts (K) + 1;
+
+ if K in N_Entity then
+ Entity_Counts (Ekind (N)) := Entity_Counts (Ekind (N)) + 1;
+ end if;
+ end;
+ end loop;
+
+ for K in Node_Kind loop
+ declare
+ Count : constant Nat_64 := Node_Counts (K);
+ begin
+ Write_Int_64 (Count);
+ Write_Ratio (Count, Int_64 (Node_Offsets.Last));
+ Write_Str (" ");
+ Write_Str (Node_Kind'Image (K));
+ Write_Str (" ");
+ Write_Int (Int (Sinfo.Nodes.Size (K)));
+ Write_Str (" slots");
+ Write_Eol;
+ end;
+ end loop;
+
+ for K in Entity_Kind loop
+ declare
+ Count : constant Nat_64 := Entity_Counts (K);
+ begin
+ Write_Int_64 (Count);
+ Write_Ratio (Count, Int_64 (Node_Offsets.Last));
+ Write_Str (" ");
+ Write_Str (Entity_Kind'Image (K));
+ Write_Str (" ");
+ Write_Int (Int (Einfo.Entities.Size (K)));
+ Write_Str (" slots");
+ Write_Eol;
+ end;
+ end loop;
+ end Print_Node_Statistics;
+
+ procedure Print_Field_Statistics is
+ Total, G_Total, S_Total : Call_Count := 0;
+ begin
+ Write_Int_64 (Get_Original_Node_Count);
+ Write_Str (" + ");
+ Write_Int_64 (Set_Original_Node_Count);
+ Write_Eol;
+ Write_Line (" Original_Node_Count getter and setter calls");
+ Write_Eol;
+
+ Write_Line ("Frequency of field getter and setter calls:");
+
+ for Field in Node_Or_Entity_Field loop
+ G_Total := G_Total + Get_Count (Field);
+ S_Total := S_Total + Set_Count (Field);
+ Total := G_Total + S_Total;
+ end loop;
+
+ -- This assertion helps CodePeer understand that Total cannot be 0 (this
+ -- is true because GNAT does not attempt to compile empty files).
+ pragma Assert (Total > 0);
+
+ Write_Int_64 (Total);
+ Write_Str (" (100%) = ");
+ Write_Int_64 (G_Total);
+ Write_Str (" + ");
+ Write_Int_64 (S_Total);
+ Write_Line (" total getter and setter calls");
+
+ for Field in Node_Or_Entity_Field loop
+ declare
+ G : constant Call_Count := Get_Count (Field);
+ S : constant Call_Count := Set_Count (Field);
+ GS : constant Call_Count := G + S;
+
+ Desc : Field_Descriptor renames Field_Descriptors (Field);
+ Slot : constant Field_Offset :=
+ (Field_Size (Desc.Kind) * Desc.Offset) / Slot_Size;
+
+ begin
+ Write_Int_64 (GS);
+ Write_Ratio (GS, Total);
+ Write_Str (" = ");
+ Write_Int_64 (G);
+ Write_Str (" + ");
+ Write_Int_64 (S);
+ Write_Str (" ");
+ Write_Str (Node_Or_Entity_Field'Image (Field));
+ Write_Str (" in slot ");
+ Write_Int (Int (Slot));
+ Write_Str (" size ");
+ Write_Int (Int (Field_Size (Desc.Kind)));
+ Write_Eol;
+ end;
+ end loop;
+ end Print_Field_Statistics;
+
+ procedure Print_Statistics is
+ begin
+ Write_Eol;
+ Write_Eol;
+ Print_Node_Statistics;
+ Print_Field_Statistics;
+ end Print_Statistics;
+
end Atree;
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 6fb5aa6..2f3ca40 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -48,6 +48,7 @@
with Sinfo.Nodes; use Sinfo.Nodes;
with Einfo.Entities; use Einfo.Entities;
with Types; use Types;
+with Seinfo; use Seinfo;
with System; use System;
with Table;
with Unchecked_Conversion;
@@ -501,6 +502,7 @@
-- the contents of these two nodes fixing up the parent pointers of the
-- replaced node (we do not attempt to preserve parent pointers for the
-- original node). Neither Old_Node nor New_Node can be extended nodes.
+ -- ??? The above explanation is incorrect, instead Copy_Node is called.
--
-- Note: New_Node may not contain references to Old_Node, for example as
-- descendants, since the rewrite would make such references invalid. If
@@ -565,10 +567,9 @@
type Entity_Field_Set is array (Entity_Field) of Boolean with Pack;
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field);
- procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field);
+ procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Or_Entity_Field);
-- When a node is created, all fields are initialized to zero, even if zero
- -- is not a valid value of the field type. These procedures put the field
+ -- is not a valid value of the field type. This procedure puts the field
-- back to its initial zero value. Note that you can't just do something
-- like Set_Some_Field (N, 0), if Some_Field is of (say) type Uintp,
-- because Uintp is a subrange that does not include 0.
@@ -582,9 +583,7 @@
-- this.
function Field_Is_Initial_Zero
- (N : Node_Id; Field : Node_Field) return Boolean;
- function Field_Is_Initial_Zero
- (N : Entity_Id; Field : Entity_Field) return Boolean;
+ (N : Node_Id; Field : Node_Or_Entity_Field) return Boolean;
-- True if the field value is the initial zero value
procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) with Inline;
@@ -610,10 +609,6 @@
-- always the same; for example we change from E_Void, to E_Variable, to
-- E_Void, to E_Constant.
- procedure Print_Atree_Info (N : Node_Or_Entity_Id);
- -- Called from Treepr to print out information about N that is private to
- -- Atree.
-
-----------------------------
-- Private Part Subpackage --
-----------------------------
@@ -638,7 +633,7 @@
-- The nodes of the tree are stored in two tables (i.e. growable
-- arrays).
- -- A Node_Id points to an element of Nodes, which contains a
+ -- A Node_Id points to an element of Node_Offsets, which contains a
-- Field_Offset that points to an element of Slots. Each slot can
-- contain a single 32-bit field, or multiple smaller fields.
-- An n-bit field is aligned on an n-bit boundary. The size of a node is
@@ -648,12 +643,40 @@
-- The reason for the extra level of indirection is that Copy_Node,
-- Exchange_Entities, and Rewrite all assume that nodes can be modified
-- in place.
+ --
+ -- As an optimization, we store a few slots directly in the Node_Offsets
+ -- table (see type Node_Header) rather than requiring the extra level of
+ -- indirection for accessing those slots. N_Head is the number of slots
+ -- stored in the Node_Header. N_Head can be adjusted by modifying
+ -- Gen_IL.Gen. If N_Head is (say) 3, then a node containing 7 slots will
+ -- have slots 0..2 in the header, and 3..6 stored indirect in the Slots
+ -- table. We use zero-origin addressing, so the Offset into the Slots
+ -- table will point 3 slots before slot 3.
- subtype Node_Offset is Field_Offset'Base
- range 1 .. Field_Offset'Base'Last;
+ pragma Assert (N_Head <= Min_Node_Size);
+ pragma Assert (N_Head <= Min_Entity_Size);
+
+ Slot_Size : constant := 32;
+ type Slot is mod 2**Slot_Size;
+ for Slot'Size use Slot_Size;
+
+ -- The type Slot is defined in Types as a 32-bit modular integer. It
+ -- is logically split into the appropriate numbers of components of
+ -- appropriate size, but this splitting is not explicit because packed
+ -- arrays cannot be properly interfaced in C/C++ and packed records are
+ -- way too slow.
+
+ type Node_Header_Slots is
+ array (Field_Offset range 0 .. N_Head - 1) of Slot;
+ type Node_Header is record
+ Slots : Node_Header_Slots;
+ Offset : Node_Offset'Base;
+ end record;
+ pragma Assert (Node_Header'Size = (N_Head + 1) * Slot_Size);
+ pragma Assert (Node_Header'Size = 16 * 8);
package Node_Offsets is new Table.Table
- (Table_Component_Type => Node_Offset,
+ (Table_Component_Type => Node_Header,
Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Node_Offsets_Initial,
@@ -667,15 +690,6 @@
-- Short names for use in gdb, not used in real code. Note that gdb
-- can't find Node_Offsets.Table without a full expanded name.
- -- We define the type Slot as a 32-bit modular integer. It is logically
- -- split into the appropriate numbers of components of appropriate size,
- -- but this splitting is not explicit because packed arrays cannot be
- -- properly interfaced in C/C++ and packed records are way too slow.
-
- Slot_Size : constant := 32;
- type Slot is mod 2**Slot_Size;
- for Slot'Size use Slot_Size;
-
function Shift_Left (S : Slot; V : Natural) return Slot;
pragma Import (Intrinsic, Shift_Left);
@@ -855,6 +869,22 @@
function Is_Valid_Node (U : Union_Id) return Boolean;
-- True if U is within the range of Node_Offsets
+ procedure Print_Atree_Info (N : Node_Or_Entity_Id);
+ -- Called from Treepr to print out information about N that is private
+ -- to Atree.
+
end Atree_Private_Part;
+ -- Statistics:
+
+ subtype Call_Count is Nat_64;
+ Get_Count, Set_Count : array (Node_Or_Entity_Field) of Call_Count :=
+ (others => 0);
+ -- Number of calls to each getter and setter. See documentaton for
+ -- -gnatd.A.
+
+ Get_Original_Node_Count, Set_Original_Node_Count : Call_Count := 0;
+
+ procedure Print_Statistics;
+
end Atree;
diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h
index 08b791c..7fb3bcb 100644
--- a/gcc/ada/atree.h
+++ b/gcc/ada/atree.h
@@ -65,77 +65,6 @@
#define Current_Error_Node atree__current_error_node
extern Node_Id Current_Error_Node;
-/* The following code corresponds to the Get_n_Bit_Field functions (for
- various n) in package Atree. The low-level getters in sinfo.h call
- these even-lower-level getters. */
-
-extern Field_Offset *Node_Offsets_Ptr;
-extern any_slot *Slots_Ptr;
-
-INLINE unsigned int Get_1_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_2_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_4_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_8_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_32_Bit_Field (Node_Id, Field_Offset);
-INLINE unsigned int Get_32_Bit_Field_With_Default (Node_Id, Field_Offset,
- unsigned int);
-INLINE unsigned int Get_Valid_32_Bit_Field (Node_Id, Field_Offset);
-
-INLINE unsigned int
-Get_1_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 1;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 1;
-}
-
-INLINE unsigned int
-Get_2_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 2;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 3;
-}
-
-INLINE unsigned int
-Get_4_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 4;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 15;
-}
-
-INLINE unsigned int
-Get_8_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- const Field_Offset L = Slot_Size / 8;
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset / L);
- return (slot >> (Offset % L) * (Slot_Size / L)) & 255;
-}
-
-INLINE unsigned int
-Get_32_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
- return slot;
-}
-
-INLINE unsigned int
-Get_32_Bit_Field_With_Default (Node_Id N, Field_Offset Offset,
- unsigned int Default_Value)
-{
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
- return slot == Empty ? Default_Value : slot;
-}
-
-INLINE unsigned int
-Get_Valid_32_Bit_Field (Node_Id N, Field_Offset Offset)
-{
- any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[N] + Offset);
- gcc_assert (slot != Empty);
- return slot;
-}
-
#ifdef __cplusplus
}
#endif
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 804e2fd..38bf2c2 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -29,6 +29,7 @@
with Butil; use Butil;
with Casing; use Casing;
with Fname; use Fname;
+with Gnatvsn;
with Namet; use Namet;
with Opt; use Opt;
with Osint;
@@ -1324,11 +1325,136 @@
or else ALIs.Table (A).Ver (1 .. VL) /=
ALIs.Table (ALIs.First).Ver (1 .. VL)
then
- Error_Msg_File_1 := ALIs.Table (A).Sfile;
- Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
+ -- Version mismatch found; generate error message.
- Consistency_Error_Msg
- ("{ and { compiled with different GNAT versions");
+ declare
+ use Gnatvsn;
+
+ Prefix : constant String :=
+ Verbose_Library_Version
+ (1 .. Verbose_Library_Version'Length
+ - Library_Version'Length);
+
+ type ALI_Version is record
+ Primary, Secondary : Int range -1 .. Int'Last;
+ end record;
+
+ No_Version : constant ALI_Version := (-1, -1);
+
+ function Remove_Prefix (S : String) return String is
+ (S (S'First + Prefix'Length .. S'Last));
+
+ function Extract_Version (S : String) return ALI_Version;
+ -- Attempts to extract and return a pair of nonnegative library
+ -- version numbers from the given string; if unsuccessful,
+ -- then returns No_Version.
+
+ ---------------------
+ -- Extract_Version --
+ ---------------------
+
+ function Extract_Version (S : String) return ALI_Version is
+ pragma Assert (S'First = 1);
+
+ function Int_Value (Img : String) return Int;
+ -- Using Int'Value leads to complications in
+ -- building the binder, so DIY.
+
+ ---------------
+ -- Int_Value --
+ ---------------
+
+ function Int_Value (Img : String) return Int is
+ Result : Nat := 0;
+ begin
+ if Img'Length in 1 .. 9
+ and then (for all C of Img => C in '0' .. '9')
+ then
+ for C of Img loop
+ Result := (10 * Result) +
+ (Character'Pos (C) - Character'Pos ('0'));
+ end loop;
+ return Result;
+ else
+ return -1;
+ end if;
+ end Int_Value;
+
+ begin
+ if S'Length > Prefix'Length
+ and then S (1 .. Prefix'Length) = Prefix
+ then
+ declare
+ Suffix : constant String := Remove_Prefix (S);
+ Dot_Found : Boolean := False;
+ Primary, Secondary : Int;
+ begin
+ for Dot_Index in Suffix'Range loop
+ if Suffix (Dot_Index) = '.' then
+ Dot_Found := True;
+ Primary :=
+ Int_Value (Suffix (Suffix'First
+ .. Dot_Index - 1));
+ Secondary :=
+ Int_Value (Suffix (Dot_Index + 1
+ .. Suffix'Last));
+ exit;
+ end if;
+ end loop;
+
+ if not Dot_Found then
+ Primary := Int_Value (Suffix);
+ Secondary := 0;
+ end if;
+
+ if (Primary /= -1) and (Secondary /= -1) then
+ return (Primary => Primary,
+ Secondary => Secondary);
+ end if;
+ end;
+ end if;
+ return No_Version;
+ end Extract_Version;
+
+ -- Local constants
+
+ V1_Text : constant String :=
+ ALIs.Table (A).Ver (1 .. ALIs.Table (A).Ver_Len);
+ V2_Text : constant String :=
+ ALIs.Table (ALIs.First).Ver (1 .. VL);
+ V1 : constant ALI_Version := Extract_Version (V1_Text);
+ V2 : constant ALI_Version := Extract_Version (V2_Text);
+
+ Include_Version_Numbers_In_Message : constant Boolean :=
+ (V1 /= V2) and (V1 /= No_Version) and (V2 /= No_Version);
+ begin
+ Error_Msg_File_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
+
+ if Include_Version_Numbers_In_Message then
+ if V1.Secondary = V2.Secondary then
+ -- Excluding equal secondary values from error
+ -- message text matters for generating reproducible
+ -- regression test outputs.
+
+ Error_Msg_Nat_1 := V1.Primary;
+ Error_Msg_Nat_2 := V2.Primary;
+ Consistency_Error_Msg
+ ("{ and { compiled with different GNAT versions"
+ & ", v# and v#");
+ else
+ Consistency_Error_Msg
+ ("{ and { compiled with different GNAT versions"
+ & ", v"
+ & Remove_Prefix (V1_Text)
+ & " and v"
+ & Remove_Prefix (V2_Text));
+ end if;
+ else
+ Consistency_Error_Msg
+ ("{ and { compiled with different GNAT versions");
+ end if;
+ end;
end if;
end loop;
end Check_Versions;
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 8f5c0b0..a58a495 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -3552,9 +3552,12 @@
-- Apply_Subscript_Validity_Checks --
-------------------------------------
- procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
+ procedure Apply_Subscript_Validity_Checks
+ (Expr : Node_Id;
+ No_Check_Needed : Dimension_Set := Empty_Dimension_Set) is
Sub : Node_Id;
+ Dimension : Pos := 1;
begin
pragma Assert (Nkind (Expr) = N_Indexed_Component);
@@ -3568,11 +3571,16 @@
-- for the subscript, and that convert will do the necessary validity
-- check.
- Ensure_Valid (Sub, Holes_OK => True);
+ if (No_Check_Needed = Empty_Dimension_Set)
+ or else not No_Check_Needed.Elements (Dimension)
+ then
+ Ensure_Valid (Sub, Holes_OK => True);
+ end if;
-- Move to next subscript
Next (Sub);
+ Dimension := Dimension + 1;
end loop;
end Apply_Subscript_Validity_Checks;
@@ -7233,7 +7241,10 @@
-- Generate_Index_Checks --
---------------------------
- procedure Generate_Index_Checks (N : Node_Id) is
+ procedure Generate_Index_Checks
+ (N : Node_Id;
+ Checks_Generated : out Dimension_Set)
+ is
function Entity_Of_Prefix return Entity_Id;
-- Returns the entity of the prefix of N (or Empty if not found)
@@ -7268,6 +7279,8 @@
-- Start of processing for Generate_Index_Checks
begin
+ Checks_Generated.Elements := (others => False);
+
-- Ignore call if the prefix is not an array since we have a serious
-- error in the sources. Ignore it also if index checks are suppressed
-- for array object or type.
@@ -7330,6 +7343,8 @@
Prefix => New_Occurrence_Of (Etype (A), Loc),
Attribute_Name => Name_Range)),
Reason => CE_Index_Check_Failed));
+
+ Checks_Generated.Elements (1) := True;
end if;
-- General case
@@ -7416,6 +7431,8 @@
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd => Range_N),
Reason => CE_Index_Check_Failed));
+
+ Checks_Generated.Elements (Ind) := True;
end if;
Next_Index (A_Idx);
@@ -10383,7 +10400,7 @@
Exptyp : Entity_Id;
Cond : Node_Id := Empty;
Do_Access : Boolean := False;
- Wnode : Node_Id := Warn_Node;
+ Wnode : Node_Id := Warn_Node;
Ret_Result : Check_Result := (Empty, Empty);
Num_Checks : Natural := 0;
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index 3b97bd0..6df752f 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -44,6 +44,14 @@
package Checks is
+ type Bit_Vector is array (Pos range <>) of Boolean;
+ type Dimension_Set (Dimensions : Nat) is
+ record
+ Elements : Bit_Vector (1 .. Dimensions);
+ end record;
+ Empty_Dimension_Set : constant Dimension_Set
+ := (Dimensions => 0, Elements => (others => <>));
+
procedure Initialize;
-- Called for each new main source program, to initialize internal
-- variables used in the package body of the Checks unit.
@@ -721,11 +729,16 @@
-- Do_Range_Check flag, and if it is set, this routine is called, which
-- turns the flag off in code-generation mode.
- procedure Generate_Index_Checks (N : Node_Id);
+ procedure Generate_Index_Checks
+ (N : Node_Id;
+ Checks_Generated : out Dimension_Set);
-- This procedure is called to generate index checks on the subscripts for
-- the indexed component node N. Each subscript expression is examined, and
-- if the Do_Range_Check flag is set, an appropriate index check is
-- generated and the flag is reset.
+ -- The out-mode parameter Checks_Generated indicates the dimensions for
+ -- which checks were generated. Checks_Generated.Dimensions must match
+ -- the number of dimensions of the array type.
-- Similarly, we set the flag Do_Discriminant_Check in the semantic
-- analysis to indicate that a discriminant check is required for selected
@@ -858,10 +871,14 @@
-- The following procedures are used in handling validity checking
- procedure Apply_Subscript_Validity_Checks (Expr : Node_Id);
+ procedure Apply_Subscript_Validity_Checks
+ (Expr : Node_Id;
+ No_Check_Needed : Dimension_Set := Empty_Dimension_Set);
-- Expr is the node for an indexed component. If validity checking and
- -- range checking are enabled, all subscripts for this indexed component
- -- are checked for validity.
+ -- range checking are enabled, each subscript for this indexed component
+ -- whose dimension does not belong to the No_Check_Needed set is checked
+ -- for validity. No_Check_Needed.Dimensions must match the number of
+ -- dimensions of the array type or be zero.
procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id);
-- Expr is a lvalue, i.e. an expression representing the target of an
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index 03ca7a4..830a994 100644
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -217,7 +217,7 @@
if Text /= null then
The_ALI :=
- Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
+ Scan_ALI (Lib_File, Text, Err => True);
Free (Text);
-- If no error was produced while loading this ALI file,
diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index 064fae0..e009c58 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -478,6 +478,7 @@
when N_Package_Declaration
| N_Subprogram_Body
| N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
=>
Unit_Name := Defining_Unit_Name (Specification (Main));
@@ -489,10 +490,10 @@
=>
Unit_Name := Defining_Unit_Name (Main);
- -- No SCIL file generated for generic package declarations
+ -- No SCIL file generated for generic unit declarations
- when N_Generic_Package_Declaration
- | N_Generic_Package_Renaming_Declaration
+ when N_Generic_Declaration
+ | N_Generic_Renaming_Declaration
=>
return;
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index e37e092..2726486 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -47,6 +47,8 @@
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
@@ -66,6 +68,16 @@
--
-- Part_Of
+ procedure Check_Class_Condition
+ (Cond : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id;
+ Is_Precondition : Boolean);
+ -- Perform checking of class-wide pre/postcondition Cond inherited by Subp
+ -- from Par_Subp. Is_Precondition enables check specific for preconditions.
+ -- In SPARK_Mode, an inherited operation that is not overridden but has
+ -- inherited modified conditions pre/postconditions is illegal.
+
procedure Check_Type_Or_Object_External_Properties
(Type_Or_Obj_Id : Entity_Id);
-- Perform checking of external properties pragmas that is common to both
@@ -77,6 +89,12 @@
-- well as Contract_Cases, Subprogram_Variant, invariants and predicates.
-- Body_Id denotes the entity of the subprogram body.
+ procedure Set_Class_Condition
+ (Kind : Condition_Kind;
+ Subp : Entity_Id;
+ Cond : Node_Id);
+ -- Set the class-wide Kind condition of Subp
+
-----------------------
-- Add_Contract_Item --
-----------------------
@@ -386,23 +404,7 @@
| N_Generic_Subprogram_Declaration
| N_Subprogram_Declaration
then
- declare
- Subp_Id : constant Entity_Id := Defining_Entity (Decl);
-
- begin
- Analyze_Entry_Or_Subprogram_Contract (Subp_Id);
-
- -- If analysis of a class-wide pre/postcondition indicates
- -- that a class-wide clone is needed, analyze its declaration
- -- now. Its body is created when the body of the original
- -- operation is analyzed (and rewritten).
-
- if Is_Subprogram (Subp_Id)
- and then Present (Class_Wide_Clone (Subp_Id))
- then
- Analyze (Unit_Declaration_Node (Class_Wide_Clone (Subp_Id)));
- end if;
- end;
+ Analyze_Entry_Or_Subprogram_Contract (Defining_Entity (Decl));
-- Entry or subprogram bodies
@@ -1491,6 +1493,141 @@
(Type_Or_Obj_Id => Type_Id);
end Analyze_Type_Contract;
+ ---------------------------
+ -- Check_Class_Condition --
+ ---------------------------
+
+ procedure Check_Class_Condition
+ (Cond : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id;
+ Is_Precondition : Boolean)
+ is
+ function Check_Entity (N : Node_Id) return Traverse_Result;
+ -- Check reference to formal of inherited operation or to primitive
+ -- operation of root type.
+
+ ------------------
+ -- Check_Entity --
+ ------------------
+
+ function Check_Entity (N : Node_Id) return Traverse_Result is
+ New_E : Entity_Id;
+ Orig_E : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then
+ (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
+ and then
+ (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else Attribute_Name (Parent (N)) /= Name_Class)
+ then
+ -- These checks do not apply to dispatching calls within the
+ -- condition, but only to calls whose static tag is that of
+ -- the parent type.
+
+ if Is_Subprogram (Entity (N))
+ and then Nkind (Parent (N)) = N_Function_Call
+ and then Present (Controlling_Argument (Parent (N)))
+ then
+ return OK;
+ end if;
+
+ -- Determine whether entity has a renaming
+
+ Orig_E := Entity (N);
+ New_E := Get_Mapped_Entity (Orig_E);
+
+ if Present (New_E) then
+
+ -- AI12-0166: A precondition for a protected operation
+ -- cannot include an internal call to a protected function
+ -- of the type. In the case of an inherited condition for an
+ -- overriding operation, both the operation and the function
+ -- are given by primitive wrappers.
+
+ if Is_Precondition
+ and then Ekind (New_E) = E_Function
+ and then Is_Primitive_Wrapper (New_E)
+ and then Is_Primitive_Wrapper (Subp)
+ and then Scope (Subp) = Scope (New_E)
+ then
+ Error_Msg_Node_2 := Wrapped_Entity (Subp);
+ Error_Msg_NE
+ ("internal call to& cannot appear in inherited "
+ & "precondition of protected operation&",
+ Subp, Wrapped_Entity (New_E));
+ end if;
+ end if;
+
+ -- Check that there are no calls left to abstract operations if
+ -- the current subprogram is not abstract.
+
+ if Present (New_E)
+ and then Nkind (Parent (N)) = N_Function_Call
+ and then N = Name (Parent (N))
+ then
+ if not Is_Abstract_Subprogram (Subp)
+ and then Is_Abstract_Subprogram (New_E)
+ then
+ Error_Msg_Sloc := Sloc (Current_Scope);
+ Error_Msg_Node_2 := Subp;
+
+ if Comes_From_Source (Subp) then
+ Error_Msg_NE
+ ("cannot call abstract subprogram & in inherited "
+ & "condition for&#", Subp, New_E);
+ else
+ Error_Msg_NE
+ ("cannot call abstract subprogram & in inherited "
+ & "condition for inherited&#", Subp, New_E);
+ end if;
+
+ -- In SPARK mode, report error on inherited condition for an
+ -- inherited operation if it contains a call to an overriding
+ -- operation, because this implies that the pre/postconditions
+ -- of the inherited operation have changed silently.
+
+ elsif SPARK_Mode = On
+ and then Warn_On_Suspicious_Contract
+ and then Present (Alias (Subp))
+ and then Present (New_E)
+ and then Comes_From_Source (New_E)
+ then
+ Error_Msg_N
+ ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
+ Parent (Subp));
+ Error_Msg_Sloc := Sloc (New_E);
+ Error_Msg_Node_2 := Subp;
+ Error_Msg_NE
+ ("\overriding of&# forces overriding of&",
+ Parent (Subp), New_E);
+ end if;
+ end if;
+ end if;
+
+ return OK;
+ end Check_Entity;
+
+ procedure Check_Condition_Entities is
+ new Traverse_Proc (Check_Entity);
+
+ -- Start of processing for Check_Class_Condition
+
+ begin
+ -- No check required if the subprograms match
+
+ if Par_Subp = Subp then
+ return;
+ end if;
+
+ Update_Primitives_Mapping (Par_Subp, Subp);
+ Map_Formals (Par_Subp, Subp);
+ Check_Condition_Entities (Cond);
+ end Check_Class_Condition;
+
-----------------------------
-- Create_Generic_Contract --
-----------------------------
@@ -1900,7 +2037,7 @@
procedure Add_Stable_Property_Contracts
(Subp_Id : Entity_Id; Class_Present : Boolean)
is
- Loc : constant Source_Ptr := Sloc (Subp_Id);
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
procedure Insert_Stable_Property_Check
(Formal : Entity_Id; Property_Function : Entity_Id);
@@ -2552,13 +2689,38 @@
---------------------------------
procedure Process_Spec_Postconditions is
- Subps : constant Subprogram_List :=
- Inherited_Subprograms (Spec_Id);
+ Subps : constant Subprogram_List :=
+ Inherited_Subprograms (Spec_Id);
+ Seen : Subprogram_List (Subps'Range) := (others => Empty);
+
+ function Seen_Subp (Subp_Id : Entity_Id) return Boolean;
+ -- Return True if the contract of subprogram Subp_Id has been
+ -- processed.
+
+ ---------------
+ -- Seen_Subp --
+ ---------------
+
+ function Seen_Subp (Subp_Id : Entity_Id) return Boolean is
+ begin
+ for Index in Seen'Range loop
+ if Seen (Index) = Subp_Id then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Seen_Subp;
+
+ -- Local variables
+
Item : Node_Id;
Items : Node_Id;
Prag : Node_Id;
Subp_Id : Entity_Id;
+ -- Start of processing for Process_Spec_Postconditions
+
begin
-- Process the contract
@@ -2589,7 +2751,7 @@
Subp_Id := Ultimate_Alias (Subp_Id);
end if;
- -- Wrappers of class-wide pre/post conditions reference the
+ -- Wrappers of class-wide pre/postconditions reference the
-- parent primitive that has the inherited contract.
if Is_Wrapper (Subp_Id)
@@ -2600,7 +2762,9 @@
Items := Contract (Subp_Id);
- if Present (Items) then
+ if not Seen_Subp (Subp_Id) and then Present (Items) then
+ Seen (Index) := Subp_Id;
+
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
if Pragma_Name (Prag) = Name_Postcondition
@@ -2657,10 +2821,6 @@
---------------------------
procedure Process_Preconditions is
- Class_Pre : Node_Id := Empty;
- -- The sole [inherited] class-wide precondition pragma that applies
- -- to the subprogram.
-
Insert_Node : Node_Id := Empty;
-- The insertion node after which all pragma Check equivalents are
-- inserted.
@@ -2669,21 +2829,12 @@
-- Determine whether arbitrary declaration Decl denotes a renaming of
-- a discriminant or protection field _object.
- procedure Merge_Preconditions (From : Node_Id; Into : Node_Id);
- -- Merge two class-wide preconditions by "or else"-ing them. The
- -- changes are accumulated in parameter Into. Update the error
- -- message of Into.
-
procedure Prepend_To_Decls (Item : Node_Id);
-- Prepend a single item to the declarations of the subprogram body
- procedure Prepend_To_Decls_Or_Save (Prag : Node_Id);
- -- Save a class-wide precondition into Class_Pre, or prepend a normal
- -- precondition to the declarations of the body and analyze it.
-
- procedure Process_Inherited_Preconditions;
- -- Collect all inherited class-wide preconditions and merge them into
- -- one big precondition to be evaluated as pragma Check.
+ procedure Prepend_Pragma_To_Decls (Prag : Node_Id);
+ -- Prepend a normal precondition to the declarations of the body and
+ -- analyze it.
procedure Process_Preconditions_For (Subp_Id : Entity_Id);
-- Collect all preconditions of subprogram Subp_Id and prepend their
@@ -2737,78 +2888,6 @@
return False;
end Is_Prologue_Renaming;
- -------------------------
- -- Merge_Preconditions --
- -------------------------
-
- procedure Merge_Preconditions (From : Node_Id; Into : Node_Id) is
- function Expression_Arg (Prag : Node_Id) return Node_Id;
- -- Return the boolean expression argument of a precondition while
- -- updating its parentheses count for the subsequent merge.
-
- function Message_Arg (Prag : Node_Id) return Node_Id;
- -- Return the message argument of a precondition
-
- --------------------
- -- Expression_Arg --
- --------------------
-
- function Expression_Arg (Prag : Node_Id) return Node_Id is
- Args : constant List_Id := Pragma_Argument_Associations (Prag);
- Arg : constant Node_Id := Get_Pragma_Arg (Next (First (Args)));
-
- begin
- if Paren_Count (Arg) = 0 then
- Set_Paren_Count (Arg, 1);
- end if;
-
- return Arg;
- end Expression_Arg;
-
- -----------------
- -- Message_Arg --
- -----------------
-
- function Message_Arg (Prag : Node_Id) return Node_Id is
- Args : constant List_Id := Pragma_Argument_Associations (Prag);
- begin
- return Get_Pragma_Arg (Last (Args));
- end Message_Arg;
-
- -- Local variables
-
- From_Expr : constant Node_Id := Expression_Arg (From);
- From_Msg : constant Node_Id := Message_Arg (From);
- Into_Expr : constant Node_Id := Expression_Arg (Into);
- Into_Msg : constant Node_Id := Message_Arg (Into);
- Loc : constant Source_Ptr := Sloc (Into);
-
- -- Start of processing for Merge_Preconditions
-
- begin
- -- Merge the two preconditions by "or else"-ing them
-
- Rewrite (Into_Expr,
- Make_Or_Else (Loc,
- Right_Opnd => Relocate_Node (Into_Expr),
- Left_Opnd => From_Expr));
-
- -- Merge the two error messages to produce a single message of the
- -- form:
-
- -- failed precondition from ...
- -- also failed inherited precondition from ...
-
- if not Exception_Locations_Suppressed then
- Start_String (Strval (Into_Msg));
- Store_String_Char (ASCII.LF);
- Store_String_Chars (" also ");
- Store_String_Chars (Strval (From_Msg));
-
- Set_Strval (Into_Msg, End_String);
- end if;
- end Merge_Preconditions;
-
----------------------
-- Prepend_To_Decls --
----------------------
@@ -2829,28 +2908,27 @@
Prepend_To (Decls, Item);
end Prepend_To_Decls;
- ------------------------------
- -- Prepend_To_Decls_Or_Save --
- ------------------------------
+ -----------------------------
+ -- Prepend_Pragma_To_Decls --
+ -----------------------------
- procedure Prepend_To_Decls_Or_Save (Prag : Node_Id) is
+ procedure Prepend_Pragma_To_Decls (Prag : Node_Id) is
Check_Prag : Node_Id;
begin
- Check_Prag := Build_Pragma_Check_Equivalent (Prag);
-
- -- Save the sole class-wide precondition (if any) for the next
- -- step, where it will be merged with inherited preconditions.
+ -- Skip the sole class-wide precondition (if any) since it is
+ -- processed by Merge_Class_Conditions.
if Class_Present (Prag) then
- pragma Assert (No (Class_Pre));
- Class_Pre := Check_Prag;
+ null;
-- Accumulate the corresponding Check pragmas at the top of the
-- declarations. Prepending the items ensures that they will be
-- evaluated in their original order.
else
+ Check_Prag := Build_Pragma_Check_Equivalent (Prag);
+
if Present (Insert_Node) then
Insert_After (Insert_Node, Check_Prag);
else
@@ -2859,87 +2937,7 @@
Analyze (Check_Prag);
end if;
- end Prepend_To_Decls_Or_Save;
-
- -------------------------------------
- -- Process_Inherited_Preconditions --
- -------------------------------------
-
- procedure Process_Inherited_Preconditions is
- Subps : constant Subprogram_List :=
- Inherited_Subprograms (Spec_Id);
-
- Item : Node_Id;
- Items : Node_Id;
- Prag : Node_Id;
- Subp_Id : Entity_Id;
-
- begin
- -- Process the contracts of all inherited subprograms, looking for
- -- class-wide preconditions.
-
- for Index in Subps'Range loop
- Subp_Id := Subps (Index);
-
- if Present (Alias (Subp_Id)) then
- Subp_Id := Ultimate_Alias (Subp_Id);
- end if;
-
- -- Wrappers of class-wide pre/post conditions reference the
- -- parent primitive that has the inherited contract.
-
- if Is_Wrapper (Subp_Id)
- and then Present (LSP_Subprogram (Subp_Id))
- then
- Subp_Id := LSP_Subprogram (Subp_Id);
- end if;
-
- Items := Contract (Subp_Id);
-
- if Present (Items) then
- Prag := Pre_Post_Conditions (Items);
- while Present (Prag) loop
- if Pragma_Name (Prag) = Name_Precondition
- and then Class_Present (Prag)
- then
- Item :=
- Build_Pragma_Check_Equivalent
- (Prag => Prag,
- Subp_Id => Spec_Id,
- Inher_Id => Subp_Id);
-
- -- The pragma Check equivalent of the class-wide
- -- precondition is still created even though the
- -- pragma may be ignored because the equivalent
- -- performs semantic checks.
-
- if Is_Checked (Prag) then
-
- -- The spec of an inherited subprogram already
- -- yielded a class-wide precondition. Merge the
- -- existing precondition with the current one
- -- using "or else".
-
- if Present (Class_Pre) then
- Merge_Preconditions (Item, Class_Pre);
- else
- Class_Pre := Item;
- end if;
- end if;
- end if;
-
- Prag := Next_Pragma (Prag);
- end loop;
- end if;
- end loop;
-
- -- Add the merged class-wide preconditions
-
- if Present (Class_Pre) then
- Prepend_To_Decls (Class_Pre);
- Analyze (Class_Pre);
- end if;
- end Process_Inherited_Preconditions;
+ end Prepend_Pragma_To_Decls;
-------------------------------
-- Process_Preconditions_For --
@@ -2983,7 +2981,7 @@
N => Body_Decl);
end if;
- Prepend_To_Decls_Or_Save (Prag);
+ Prepend_Pragma_To_Decls (Prag);
end if;
Prag := Next_Pragma (Prag);
@@ -3008,7 +3006,7 @@
if Pragma_Name (Decl) = Name_Precondition
and then Is_Checked (Decl)
then
- Prepend_To_Decls_Or_Save (Decl);
+ Prepend_Pragma_To_Decls (Decl);
end if;
-- Skip internally generated code
@@ -3073,22 +3071,21 @@
Next (Decl);
end loop;
+
+ -- The processing of preconditions is done in reverse order (body
+ -- first), because each pragma Check equivalent is inserted at the
+ -- top of the declarations. This ensures that the final order is
+ -- consistent with following diagram:
+
+ -- <inherited preconditions>
+ -- <preconditions from spec>
+ -- <preconditions from body>
+
+ Process_Preconditions_For (Body_Id);
end if;
- -- The processing of preconditions is done in reverse order (body
- -- first), because each pragma Check equivalent is inserted at the
- -- top of the declarations. This ensures that the final order is
- -- consistent with following diagram:
-
- -- <inherited preconditions>
- -- <preconditions from spec>
- -- <preconditions from body>
-
- Process_Preconditions_For (Body_Id);
-
if Present (Spec_Id) then
Process_Preconditions_For (Spec_Id);
- Process_Inherited_Preconditions;
end if;
end Process_Preconditions;
@@ -3139,6 +3136,12 @@
elsif Is_Ignored_Ghost_Entity (Subp_Id) then
return;
+ -- No action needed for helpers and indirect-call wrapper built to
+ -- support class-wide preconditions.
+
+ elsif Present (Class_Preconditions_Subprogram (Subp_Id)) then
+ return;
+
-- Do not re-expand the same contract. This scenario occurs when a
-- construct is rewritten into something else during its analysis
-- (expression functions for instance).
@@ -3440,7 +3443,7 @@
-- Get_Postcond_Enabled --
--------------------------
- function Get_Postcond_Enabled (Subp : Entity_Id) return Node_Id is
+ function Get_Postcond_Enabled (Subp : Entity_Id) return Entity_Id is
Decl : Node_Id;
begin
Decl :=
@@ -3465,7 +3468,7 @@
------------------------------------
function Get_Result_Object_For_Postcond
- (Subp : Entity_Id) return Node_Id
+ (Subp : Entity_Id) return Entity_Id
is
Decl : Node_Id;
begin
@@ -3490,7 +3493,7 @@
-- Get_Return_Success_For_Postcond --
-------------------------------------
- function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Node_Id
+ function Get_Return_Success_For_Postcond (Subp : Entity_Id) return Entity_Id
is
Decl : Node_Id;
begin
@@ -3605,6 +3608,1112 @@
end if;
end Instantiate_Subprogram_Contract;
+ -----------------------------------
+ -- Make_Class_Precondition_Subps --
+ -----------------------------------
+
+ procedure Make_Class_Precondition_Subps
+ (Subp_Id : Entity_Id;
+ Late_Overriding : Boolean := False)
+ is
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
+ Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
+
+ procedure Add_Indirect_Call_Wrapper;
+ -- Build the indirect-call wrapper and append it to the freezing actions
+ -- of Tagged_Type.
+
+ procedure Add_Call_Helper
+ (Helper_Id : Entity_Id;
+ Is_Dynamic : Boolean);
+ -- Factorizes code for building a call helper with the given identifier
+ -- and append it to the freezing actions of Tagged_Type. Is_Dynamic
+ -- controls building the static or dynamic version of the helper.
+
+ -------------------------------
+ -- Add_Indirect_Call_Wrapper --
+ -------------------------------
+
+ procedure Add_Indirect_Call_Wrapper is
+
+ function Build_ICW_Body return Node_Id;
+ -- Build the body of the indirect call wrapper
+
+ function Build_ICW_Decl return Node_Id;
+ -- Build the declaration of the indirect call wrapper
+
+ --------------------
+ -- Build_ICW_Body --
+ --------------------
+
+ function Build_ICW_Body return Node_Id is
+ ICW_Id : constant Entity_Id := Indirect_Call_Wrapper (Subp_Id);
+ Spec : constant Node_Id := Parent (ICW_Id);
+ Body_Spec : Node_Id;
+ Call : Node_Id;
+ ICW_Body : Node_Id;
+
+ begin
+ Body_Spec := Copy_Subprogram_Spec (Spec);
+
+ -- Build call to wrapped subprogram
+
+ declare
+ Actuals : constant List_Id := Empty_List;
+ Formal_Spec : Entity_Id :=
+ First (Parameter_Specifications (Spec));
+ begin
+ -- Build parameter association & call
+
+ while Present (Formal_Spec) loop
+ Append_To (Actuals,
+ New_Occurrence_Of
+ (Defining_Identifier (Formal_Spec), Loc));
+ Next (Formal_Spec);
+ end loop;
+
+ if Ekind (ICW_Id) = E_Procedure then
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Subp_Id, Loc),
+ Parameter_Associations => Actuals);
+ else
+ Call :=
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Subp_Id, Loc),
+ Parameter_Associations => Actuals));
+ end if;
+ end;
+
+ ICW_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => Body_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call)));
+
+ -- The new operation is internal and overriding indicators do not
+ -- apply.
+
+ Set_Must_Override (Body_Spec, False);
+
+ return ICW_Body;
+ end Build_ICW_Body;
+
+ --------------------
+ -- Build_ICW_Decl --
+ --------------------
+
+ function Build_ICW_Decl return Node_Id is
+ ICW_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Subp_Id),
+ Suffix => "ICW",
+ Suffix_Index => Source_Offset (Loc)));
+ Decl : Node_Id;
+ Spec : Node_Id;
+
+ begin
+ Spec := Copy_Subprogram_Spec (Parent (Subp_Id));
+ Set_Must_Override (Spec, False);
+ Set_Must_Not_Override (Spec, False);
+ Set_Defining_Unit_Name (Spec, ICW_Id);
+ Mutate_Ekind (ICW_Id, Ekind (Subp_Id));
+ Set_Is_Public (ICW_Id);
+
+ -- The indirect call wrapper is commonly used for indirect calls
+ -- but inlined for direct calls performed from the DTW.
+
+ Set_Is_Inlined (ICW_Id);
+
+ if Nkind (Spec) = N_Procedure_Specification then
+ Set_Null_Present (Spec, False);
+ end if;
+
+ Decl := Make_Subprogram_Declaration (Loc, Spec);
+
+ -- Link original subprogram to indirect wrapper and vice versa
+
+ Set_Indirect_Call_Wrapper (Subp_Id, ICW_Id);
+ Set_Class_Preconditions_Subprogram (ICW_Id, Subp_Id);
+
+ -- Inherit debug info flag to allow debugging the wrapper
+
+ if Needs_Debug_Info (Subp_Id) then
+ Set_Debug_Info_Needed (ICW_Id);
+ end if;
+
+ return Decl;
+ end Build_ICW_Decl;
+
+ -- Local Variables
+
+ ICW_Body : Node_Id;
+ ICW_Decl : Node_Id;
+
+ -- Start of processing for Add_Indirect_Call_Wrapper
+
+ begin
+ pragma Assert (No (Indirect_Call_Wrapper (Subp_Id)));
+
+ ICW_Decl := Build_ICW_Decl;
+
+ Ensure_Freeze_Node (Tagged_Type);
+ Append_Freeze_Action (Tagged_Type, ICW_Decl);
+ Analyze (ICW_Decl);
+
+ ICW_Body := Build_ICW_Body;
+ Append_Freeze_Action (Tagged_Type, ICW_Body);
+
+ -- We cannot defer the analysis of this ICW wrapper when it is
+ -- built as a consequence of building its partner DTW wrapper
+ -- at the freezing point of the tagged type.
+
+ if Is_Dispatch_Table_Wrapper (Subp_Id) then
+ Analyze (ICW_Body);
+ end if;
+ end Add_Indirect_Call_Wrapper;
+
+ ---------------------
+ -- Add_Call_Helper --
+ ---------------------
+
+ procedure Add_Call_Helper
+ (Helper_Id : Entity_Id;
+ Is_Dynamic : Boolean)
+ is
+ function Build_Call_Helper_Body return Node_Id;
+ -- Build the body of a call helper
+
+ function Build_Call_Helper_Decl return Node_Id;
+ -- Build the declaration of a call helper
+
+ function Build_Call_Helper_Spec (Spec_Id : Entity_Id) return Node_Id;
+ -- Build the specification of the helper
+
+ ----------------------------
+ -- Build_Call_Helper_Body --
+ ----------------------------
+
+ function Build_Call_Helper_Body return Node_Id is
+
+ function Copy_And_Update_References
+ (Expr : Node_Id) return Node_Id;
+ -- Copy Expr updating references to formals of Helper_Id; update
+ -- also references to loop identifiers of quantified expressions.
+
+ --------------------------------
+ -- Copy_And_Update_References --
+ --------------------------------
+
+ function Copy_And_Update_References
+ (Expr : Node_Id) return Node_Id
+ is
+ Assoc_List : constant Elist_Id := New_Elmt_List;
+
+ procedure Map_Quantified_Expression_Loop_Identifiers;
+ -- Traverse Expr and append to Assoc_List the mapping of loop
+ -- identifers of quantified expressions with its new copy.
+
+ ------------------------------------------------
+ -- Map_Quantified_Expression_Loop_Identifiers --
+ ------------------------------------------------
+
+ procedure Map_Quantified_Expression_Loop_Identifiers is
+ function Map_Loop_Param (N : Node_Id) return Traverse_Result;
+ -- Append to Assoc_List the mapping of loop identifers of
+ -- quantified expressions with its new copy.
+
+ --------------------
+ -- Map_Loop_Param --
+ --------------------
+
+ function Map_Loop_Param (N : Node_Id) return Traverse_Result
+ is
+ begin
+ if Nkind (N) = N_Loop_Parameter_Specification
+ and then Nkind (Parent (N)) = N_Quantified_Expression
+ then
+ declare
+ Def_Id : constant Entity_Id :=
+ Defining_Identifier (N);
+ begin
+ Append_Elmt (Def_Id, Assoc_List);
+ Append_Elmt (New_Copy (Def_Id), Assoc_List);
+ end;
+ end if;
+
+ return OK;
+ end Map_Loop_Param;
+
+ procedure Map_Quantified_Expressions is
+ new Traverse_Proc (Map_Loop_Param);
+
+ begin
+ Map_Quantified_Expressions (Expr);
+ end Map_Quantified_Expression_Loop_Identifiers;
+
+ -- Local variables
+
+ Subp_Formal_Id : Entity_Id := First_Formal (Subp_Id);
+ Helper_Formal_Id : Entity_Id := First_Formal (Helper_Id);
+
+ -- Start of processing for Copy_And_Update_References
+
+ begin
+ while Present (Subp_Formal_Id) loop
+ Append_Elmt (Subp_Formal_Id, Assoc_List);
+ Append_Elmt (Helper_Formal_Id, Assoc_List);
+
+ Next_Formal (Subp_Formal_Id);
+ Next_Formal (Helper_Formal_Id);
+ end loop;
+
+ Map_Quantified_Expression_Loop_Identifiers;
+
+ return New_Copy_Tree (Expr, Map => Assoc_List);
+ end Copy_And_Update_References;
+
+ -- Local variables
+
+ Helper_Decl : constant Node_Id := Parent (Parent (Helper_Id));
+ Body_Id : Entity_Id;
+ Body_Spec : Node_Id;
+ Body_Stmts : Node_Id;
+ Helper_Body : Node_Id;
+ Return_Expr : Node_Id;
+
+ -- Start of processing for Build_Call_Helper_Body
+
+ begin
+ pragma Assert (Analyzed (Unit_Declaration_Node (Helper_Id)));
+ pragma Assert (No (Corresponding_Body (Helper_Decl)));
+
+ Body_Id := Make_Defining_Identifier (Loc, Chars (Helper_Id));
+ Body_Spec := Build_Call_Helper_Spec (Body_Id);
+
+ Set_Corresponding_Body (Helper_Decl, Body_Id);
+ Set_Must_Override (Body_Spec, False);
+
+ if Present (Class_Preconditions (Subp_Id)) then
+ Return_Expr :=
+ Copy_And_Update_References (Class_Preconditions (Subp_Id));
+
+ -- When the subprogram is compiled with assertions disabled the
+ -- helper just returns True; done to avoid reporting errors at
+ -- link time since a unit may be compiled with assertions disabled
+ -- and another (which depends on it) compiled with assertions
+ -- enabled.
+
+ else
+ pragma Assert (Present (Ignored_Class_Preconditions (Subp_Id)));
+ Return_Expr := New_Occurrence_Of (Standard_True, Loc);
+ end if;
+
+ Body_Stmts :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc, Return_Expr)));
+
+ Helper_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => Body_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence => Body_Stmts);
+
+ return Helper_Body;
+ end Build_Call_Helper_Body;
+
+ ----------------------------
+ -- Build_Call_Helper_Decl --
+ ----------------------------
+
+ function Build_Call_Helper_Decl return Node_Id is
+ Decl : Node_Id;
+ Spec : Node_Id;
+
+ begin
+ Spec := Build_Call_Helper_Spec (Helper_Id);
+ Set_Must_Override (Spec, False);
+ Set_Must_Not_Override (Spec, False);
+ Set_Is_Inlined (Helper_Id);
+ Set_Is_Public (Helper_Id);
+
+ Decl := Make_Subprogram_Declaration (Loc, Spec);
+
+ -- Inherit debug info flag from Subp_Id to Helper_Id to allow
+ -- debugging of the helper subprogram.
+
+ if Needs_Debug_Info (Subp_Id) then
+ Set_Debug_Info_Needed (Helper_Id);
+ end if;
+
+ return Decl;
+ end Build_Call_Helper_Decl;
+
+ ----------------------------
+ -- Build_Call_Helper_Spec --
+ ----------------------------
+
+ function Build_Call_Helper_Spec (Spec_Id : Entity_Id) return Node_Id
+ is
+ Spec : constant Node_Id := Parent (Subp_Id);
+ Def_Id : constant Node_Id := Defining_Unit_Name (Spec);
+ Formal : Entity_Id;
+ Func_Formals : constant List_Id := New_List;
+ P_Spec : constant List_Id := Parameter_Specifications (Spec);
+ Par_Formal : Node_Id;
+ Param : Node_Id;
+ Param_Type : Node_Id;
+
+ begin
+ -- Create a list of formal parameters with the same types as the
+ -- original subprogram but changing the controlling formal.
+
+ Param := First (P_Spec);
+ Formal := First_Formal (Def_Id);
+ while Present (Formal) loop
+ Par_Formal := Parent (Formal);
+
+ if Is_Dynamic and then Is_Controlling_Formal (Formal) then
+ if Nkind (Parameter_Type (Par_Formal))
+ = N_Access_Definition
+ then
+ Param_Type :=
+ Copy_Separate_Tree (Parameter_Type (Par_Formal));
+ Rewrite (Subtype_Mark (Param_Type),
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Subtype_Mark (Param_Type)),
+ Attribute_Name => Name_Class));
+
+ else
+ Param_Type :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Etype (Formal), Loc),
+ Attribute_Name => Name_Class);
+ end if;
+ else
+ Param_Type := New_Occurrence_Of (Etype (Formal), Loc);
+ end if;
+
+ Append_To (Func_Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars (Formal)),
+ In_Present => In_Present (Par_Formal),
+ Out_Present => Out_Present (Par_Formal),
+ Null_Exclusion_Present => Null_Exclusion_Present
+ (Par_Formal),
+ Parameter_Type => Param_Type));
+
+ Next (Param);
+ Next_Formal (Formal);
+ end loop;
+
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Spec_Id,
+ Parameter_Specifications => Func_Formals,
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+ end Build_Call_Helper_Spec;
+
+ -- Local variables
+
+ Helper_Body : Node_Id;
+ Helper_Decl : Node_Id;
+
+ -- Start of processing for Add_Call_Helper
+
+ begin
+ Helper_Decl := Build_Call_Helper_Decl;
+ Mutate_Ekind (Helper_Id, Ekind (Subp_Id));
+
+ -- Add the helper to the freezing actions of the tagged type
+
+ Ensure_Freeze_Node (Tagged_Type);
+ Append_Freeze_Action (Tagged_Type, Helper_Decl);
+ Analyze (Helper_Decl);
+
+ Helper_Body := Build_Call_Helper_Body;
+ Append_Freeze_Action (Tagged_Type, Helper_Body);
+
+ -- If this helper is built as part of building the DTW at the
+ -- freezing point of its tagged type then we cannot defer
+ -- its analysis.
+
+ if Late_Overriding then
+ pragma Assert (Is_Dispatch_Table_Wrapper (Subp_Id));
+ Analyze (Helper_Body);
+ end if;
+ end Add_Call_Helper;
+
+ -- Local variables
+
+ Helper_Id : Entity_Id;
+
+ -- Start of processing for Make_Class_Precondition_Subps
+
+ begin
+ if Present (Class_Preconditions (Subp_Id))
+ or Present (Ignored_Class_Preconditions (Subp_Id))
+ then
+ pragma Assert
+ (Comes_From_Source (Subp_Id)
+ or else Is_Dispatch_Table_Wrapper (Subp_Id));
+
+ if No (Dynamic_Call_Helper (Subp_Id)) then
+
+ -- Build and add to the freezing actions of Tagged_Type its
+ -- dynamic-call helper.
+
+ Helper_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Subp_Id),
+ Suffix => "DP",
+ Suffix_Index => Source_Offset (Loc)));
+ Add_Call_Helper (Helper_Id, Is_Dynamic => True);
+
+ -- Link original subprogram to helper and vice versa
+
+ Set_Dynamic_Call_Helper (Subp_Id, Helper_Id);
+ Set_Class_Preconditions_Subprogram (Helper_Id, Subp_Id);
+ end if;
+
+ if not Is_Abstract_Subprogram (Subp_Id)
+ and then No (Static_Call_Helper (Subp_Id))
+ then
+ -- Build and add to the freezing actions of Tagged_Type its
+ -- static-call helper.
+
+ Helper_Id :=
+ Make_Defining_Identifier (Loc,
+ New_External_Name (Chars (Subp_Id),
+ Suffix => "SP",
+ Suffix_Index => Source_Offset (Loc)));
+
+ Add_Call_Helper (Helper_Id, Is_Dynamic => False);
+
+ -- Link original subprogram to helper and vice versa
+
+ Set_Static_Call_Helper (Subp_Id, Helper_Id);
+ Set_Class_Preconditions_Subprogram (Helper_Id, Subp_Id);
+
+ -- Build and add to the freezing actions of Tagged_Type the
+ -- indirect-call wrapper.
+
+ Add_Indirect_Call_Wrapper;
+ end if;
+ end if;
+ end Make_Class_Precondition_Subps;
+
+ ----------------------------------------------
+ -- Process_Class_Conditions_At_Freeze_Point --
+ ----------------------------------------------
+
+ procedure Process_Class_Conditions_At_Freeze_Point (Typ : Entity_Id) is
+
+ procedure Check_Class_Conditions (Spec_Id : Entity_Id);
+ -- Check class-wide pre/postconditions of Spec_Id
+
+ function Has_Class_Postconditions_Subprogram
+ (Spec_Id : Entity_Id) return Boolean;
+ -- Return True if Spec_Id has (or inherits) a postconditions subprogram.
+
+ function Has_Class_Preconditions_Subprogram
+ (Spec_Id : Entity_Id) return Boolean;
+ -- Return True if Spec_Id has (or inherits) a preconditions subprogram.
+
+ ----------------------------
+ -- Check_Class_Conditions --
+ ----------------------------
+
+ procedure Check_Class_Conditions (Spec_Id : Entity_Id) is
+ Par_Subp : Entity_Id;
+
+ begin
+ for Kind in Condition_Kind loop
+ Par_Subp := Nearest_Class_Condition_Subprogram (Kind, Spec_Id);
+
+ if Present (Par_Subp) then
+ Check_Class_Condition
+ (Cond => Class_Condition (Kind, Par_Subp),
+ Subp => Spec_Id,
+ Par_Subp => Par_Subp,
+ Is_Precondition => Kind in Ignored_Class_Precondition
+ | Class_Precondition);
+ end if;
+ end loop;
+ end Check_Class_Conditions;
+
+ -----------------------------------------
+ -- Has_Class_Postconditions_Subprogram --
+ -----------------------------------------
+
+ function Has_Class_Postconditions_Subprogram
+ (Spec_Id : Entity_Id) return Boolean is
+ begin
+ return
+ Present (Nearest_Class_Condition_Subprogram
+ (Spec_Id => Spec_Id,
+ Kind => Class_Postcondition))
+ or else
+ Present (Nearest_Class_Condition_Subprogram
+ (Spec_Id => Spec_Id,
+ Kind => Ignored_Class_Postcondition));
+ end Has_Class_Postconditions_Subprogram;
+
+ ----------------------------------------
+ -- Has_Class_Preconditions_Subprogram --
+ ----------------------------------------
+
+ function Has_Class_Preconditions_Subprogram
+ (Spec_Id : Entity_Id) return Boolean is
+ begin
+ return
+ Present (Nearest_Class_Condition_Subprogram
+ (Spec_Id => Spec_Id,
+ Kind => Class_Precondition))
+ or else
+ Present (Nearest_Class_Condition_Subprogram
+ (Spec_Id => Spec_Id,
+ Kind => Ignored_Class_Precondition));
+ end Has_Class_Preconditions_Subprogram;
+
+ -- Local variables
+
+ Prim_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ));
+ Prim : Entity_Id;
+
+ -- Start of processing for Process_Class_Conditions_At_Freeze_Point
+
+ begin
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ if Has_Class_Preconditions_Subprogram (Prim)
+ or else Has_Class_Postconditions_Subprogram (Prim)
+ then
+ if Comes_From_Source (Prim) then
+ if Has_Significant_Contract (Prim) then
+ Merge_Class_Conditions (Prim);
+ end if;
+
+ -- Handle wrapper of protected operation
+
+ elsif Is_Primitive_Wrapper (Prim) then
+ Merge_Class_Conditions (Prim);
+
+ -- Check inherited class-wide conditions, excluding internal
+ -- entities built for mapping of interface primitives.
+
+ elsif Is_Derived_Type (Typ)
+ and then Present (Alias (Prim))
+ and then No (Interface_Alias (Prim))
+ then
+ Check_Class_Conditions (Prim);
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Process_Class_Conditions_At_Freeze_Point;
+
+ ----------------------------
+ -- Merge_Class_Conditions --
+ ----------------------------
+
+ procedure Merge_Class_Conditions (Spec_Id : Entity_Id) is
+
+ procedure Preanalyze_Condition
+ (Subp : Entity_Id;
+ Expr : Node_Id);
+ -- Preanalyze the class-wide condition Expr of Subp
+
+ procedure Process_Inherited_Conditions (Kind : Condition_Kind);
+ -- Collect all inherited class-wide conditions of Spec_Id and merge
+ -- them into one big condition.
+
+ --------------------------
+ -- Preanalyze_Condition --
+ --------------------------
+
+ procedure Preanalyze_Condition
+ (Subp : Entity_Id;
+ Expr : Node_Id)
+ is
+ procedure Clear_Unset_References;
+ -- Clear unset references on formals of Subp since preanalysis
+ -- occurs in a place unrelated to the actual code.
+
+ procedure Remove_Controlling_Arguments;
+ -- Traverse Expr and clear the Controlling_Argument of calls to
+ -- nonabstract functions.
+
+ procedure Remove_Formals (Id : Entity_Id);
+ -- Remove formals from homonym chains and make them not visible
+
+ ----------------------------
+ -- Clear_Unset_References --
+ ----------------------------
+
+ procedure Clear_Unset_References is
+ F : Entity_Id := First_Formal (Subp);
+
+ begin
+ while Present (F) loop
+ Set_Unset_Reference (F, Empty);
+ Next_Formal (F);
+ end loop;
+ end Clear_Unset_References;
+
+ ----------------------------------
+ -- Remove_Controlling_Arguments --
+ ----------------------------------
+
+ procedure Remove_Controlling_Arguments is
+ function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result;
+ -- Reset the Controlling_Argument of calls to nonabstract
+ -- function calls.
+
+ ---------------------
+ -- Remove_Ctrl_Arg --
+ ---------------------
+
+ function Remove_Ctrl_Arg (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Function_Call
+ and then Present (Controlling_Argument (N))
+ and then not Is_Abstract_Subprogram (Entity (Name (N)))
+ then
+ Set_Controlling_Argument (N, Empty);
+ end if;
+
+ return OK;
+ end Remove_Ctrl_Arg;
+
+ procedure Remove_Ctrl_Args is new Traverse_Proc (Remove_Ctrl_Arg);
+ begin
+ Remove_Ctrl_Args (Expr);
+ end Remove_Controlling_Arguments;
+
+ --------------------
+ -- Remove_Formals --
+ --------------------
+
+ procedure Remove_Formals (Id : Entity_Id) is
+ F : Entity_Id := First_Formal (Id);
+
+ begin
+ while Present (F) loop
+ Set_Is_Immediately_Visible (F, False);
+ Remove_Homonym (F);
+ Next_Formal (F);
+ end loop;
+ end Remove_Formals;
+
+ -- Start of processing for Preanalyze_Condition
+
+ begin
+ pragma Assert (Present (Expr));
+ pragma Assert (Inside_Class_Condition_Preanalysis = False);
+
+ Push_Scope (Subp);
+ Install_Formals (Subp);
+ Inside_Class_Condition_Preanalysis := True;
+
+ Preanalyze_And_Resolve (Expr, Standard_Boolean);
+
+ Inside_Class_Condition_Preanalysis := False;
+ Remove_Formals (Subp);
+ Pop_Scope;
+
+ -- Traverse Expr and clear the Controlling_Argument of calls to
+ -- nonabstract functions. Required since the preanalyzed condition
+ -- is not yet installed on its definite context and will be cloned
+ -- and extended in derivations with additional conditions.
+
+ Remove_Controlling_Arguments;
+
+ -- Clear also attribute Unset_Reference; again because preanalysis
+ -- occurs in a place unrelated to the actual code.
+
+ Clear_Unset_References;
+ end Preanalyze_Condition;
+
+ ----------------------------------
+ -- Process_Inherited_Conditions --
+ ----------------------------------
+
+ procedure Process_Inherited_Conditions (Kind : Condition_Kind) is
+ Tag_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
+ Subps : constant Subprogram_List := Inherited_Subprograms (Spec_Id);
+ Seen : Subprogram_List (Subps'Range) := (others => Empty);
+
+ function Inherit_Condition
+ (Par_Subp : Entity_Id;
+ Subp : Entity_Id) return Node_Id;
+ -- Inherit the class-wide condition from Par_Subp to Subp and adjust
+ -- all the references to formals in the inherited condition.
+
+ procedure Merge_Conditions (From : Node_Id; Into : Node_Id);
+ -- Merge two class-wide preconditions or postconditions (the former
+ -- are merged using "or else", and the latter are merged using "and-
+ -- then"). The changes are accumulated in parameter Into.
+
+ function Seen_Subp (Id : Entity_Id) return Boolean;
+ -- Return True if the contract of subprogram Id has been processed
+
+ -----------------------
+ -- Inherit_Condition --
+ -----------------------
+
+ function Inherit_Condition
+ (Par_Subp : Entity_Id;
+ Subp : Entity_Id) return Node_Id
+ is
+ Installed_Calls : constant Elist_Id := New_Elmt_List;
+
+ procedure Install_Original_Selected_Component (Expr : Node_Id);
+ -- Traverse the given expression searching for dispatching calls
+ -- to functions whose original nodes was a selected component,
+ -- and replacing them temporarily by a copy of their original
+ -- node. Modified calls are stored in the list Installed_Calls
+ -- (to undo this work later).
+
+ procedure Restore_Dispatching_Calls (Expr : Node_Id);
+ -- Undo the work done by Install_Original_Selected_Component.
+
+ -----------------------------------------
+ -- Install_Original_Selected_Component --
+ -----------------------------------------
+
+ procedure Install_Original_Selected_Component (Expr : Node_Id) is
+ function Install_Node (N : Node_Id) return Traverse_Result;
+ -- Process a single node
+
+ ------------------
+ -- Install_Node --
+ ------------------
+
+ function Install_Node (N : Node_Id) return Traverse_Result is
+ New_N : Node_Id;
+ Orig_Nod : Node_Id;
+
+ begin
+ if Nkind (N) = N_Function_Call
+ and then Nkind (Original_Node (N)) = N_Selected_Component
+ and then Is_Dispatching_Operation (Entity (Name (N)))
+ then
+ Orig_Nod := Original_Node (N);
+
+ -- Temporarily use the original node field to keep the
+ -- reference to this node (to undo this work later!).
+
+ New_N := New_Copy (N);
+ Set_Original_Node (New_N, Orig_Nod);
+ Append_Elmt (New_N, Installed_Calls);
+
+ Rewrite (N, Orig_Nod);
+ Set_Original_Node (N, New_N);
+ end if;
+
+ return OK;
+ end Install_Node;
+
+ procedure Install_Nodes is new Traverse_Proc (Install_Node);
+
+ begin
+ Install_Nodes (Expr);
+ end Install_Original_Selected_Component;
+
+ -------------------------------
+ -- Restore_Dispatching_Calls --
+ -------------------------------
+
+ procedure Restore_Dispatching_Calls (Expr : Node_Id) is
+ function Restore_Node (N : Node_Id) return Traverse_Result;
+ -- Process a single node
+
+ ------------------
+ -- Restore_Node --
+ ------------------
+
+ function Restore_Node (N : Node_Id) return Traverse_Result is
+ Orig_Sel_N : Node_Id;
+
+ begin
+ if Nkind (N) = N_Selected_Component
+ and then Nkind (Original_Node (N)) = N_Function_Call
+ and then Contains (Installed_Calls, Original_Node (N))
+ then
+ Orig_Sel_N := Original_Node (Original_Node (N));
+ pragma Assert (Nkind (Orig_Sel_N) = N_Selected_Component);
+ Rewrite (N, Original_Node (N));
+ Set_Original_Node (N, Orig_Sel_N);
+ end if;
+
+ return OK;
+ end Restore_Node;
+
+ procedure Restore_Nodes is new Traverse_Proc (Restore_Node);
+
+ begin
+ Restore_Nodes (Expr);
+ end Restore_Dispatching_Calls;
+
+ -- Local variables
+
+ Assoc_List : constant Elist_Id := New_Elmt_List;
+ Par_Formal_Id : Entity_Id := First_Formal (Par_Subp);
+ Subp_Formal_Id : Entity_Id := First_Formal (Subp);
+ New_Expr : Node_Id;
+ Class_Cond : Node_Id;
+
+ -- Start of processing for Inherit_Condition
+
+ begin
+ while Present (Par_Formal_Id) loop
+ Append_Elmt (Par_Formal_Id, Assoc_List);
+ Append_Elmt (Subp_Formal_Id, Assoc_List);
+
+ Next_Formal (Par_Formal_Id);
+ Next_Formal (Subp_Formal_Id);
+ end loop;
+
+ -- In order to properly preanalyze an inherited preanalyzed
+ -- condition that has occurrences of the Object.Operation
+ -- notation we must restore the original node; otherwise we
+ -- would report spurious errors.
+
+ Class_Cond := Class_Condition (Kind, Par_Subp);
+
+ Install_Original_Selected_Component (Class_Cond);
+ New_Expr := New_Copy_Tree (Class_Cond);
+ Restore_Dispatching_Calls (Class_Cond);
+
+ return New_Copy_Tree (New_Expr, Map => Assoc_List);
+ end Inherit_Condition;
+
+ ----------------------
+ -- Merge_Conditions --
+ ----------------------
+
+ procedure Merge_Conditions (From : Node_Id; Into : Node_Id) is
+ function Expression_Arg (Expr : Node_Id) return Node_Id;
+ -- Return the boolean expression argument of a condition while
+ -- updating its parentheses count for the subsequent merge.
+
+ --------------------
+ -- Expression_Arg --
+ --------------------
+
+ function Expression_Arg (Expr : Node_Id) return Node_Id is
+ begin
+ if Paren_Count (Expr) = 0 then
+ Set_Paren_Count (Expr, 1);
+ end if;
+
+ return Expr;
+ end Expression_Arg;
+
+ -- Local variables
+
+ From_Expr : constant Node_Id := Expression_Arg (From);
+ Into_Expr : constant Node_Id := Expression_Arg (Into);
+ Loc : constant Source_Ptr := Sloc (Into);
+
+ -- Start of processing for Merge_Conditions
+
+ begin
+ case Kind is
+
+ -- Merge the two preconditions by "or else"-ing them
+
+ when Ignored_Class_Precondition
+ | Class_Precondition
+ =>
+ Rewrite (Into_Expr,
+ Make_Or_Else (Loc,
+ Right_Opnd => Relocate_Node (Into_Expr),
+ Left_Opnd => From_Expr));
+
+ -- Merge the two postconditions by "and then"-ing them
+
+ when Ignored_Class_Postcondition
+ | Class_Postcondition
+ =>
+ Rewrite (Into_Expr,
+ Make_And_Then (Loc,
+ Right_Opnd => Relocate_Node (Into_Expr),
+ Left_Opnd => From_Expr));
+ end case;
+ end Merge_Conditions;
+
+ ---------------
+ -- Seen_Subp --
+ ---------------
+
+ function Seen_Subp (Id : Entity_Id) return Boolean is
+ begin
+ for Index in Seen'Range loop
+ if Seen (Index) = Id then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Seen_Subp;
+
+ -- Local variables
+
+ Class_Cond : Node_Id;
+ Cond : Node_Id;
+ Subp_Id : Entity_Id;
+ Par_Prim : Entity_Id := Empty;
+ Par_Iface_Prims : Elist_Id := No_Elist;
+
+ -- Start of processing for Process_Inherited_Conditions
+
+ begin
+ Class_Cond := Class_Condition (Kind, Spec_Id);
+
+ -- Process parent primitives looking for nearest ancestor with
+ -- class-wide conditions.
+
+ for Index in Subps'Range loop
+ Subp_Id := Subps (Index);
+
+ if No (Par_Prim)
+ and then Is_Ancestor (Find_Dispatching_Type (Subp_Id), Tag_Typ)
+ then
+ if Present (Alias (Subp_Id)) then
+ Subp_Id := Ultimate_Alias (Subp_Id);
+ end if;
+
+ -- Wrappers of class-wide pre/postconditions reference the
+ -- parent primitive that has the inherited contract and help
+ -- us to climb fast.
+
+ if Is_Wrapper (Subp_Id)
+ and then Present (LSP_Subprogram (Subp_Id))
+ then
+ Subp_Id := LSP_Subprogram (Subp_Id);
+ end if;
+
+ if not Seen_Subp (Subp_Id)
+ and then Present (Class_Condition (Kind, Subp_Id))
+ then
+ Seen (Index) := Subp_Id;
+ Par_Prim := Subp_Id;
+ Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim);
+
+ Cond := Inherit_Condition
+ (Subp => Spec_Id,
+ Par_Subp => Subp_Id);
+
+ if Present (Class_Cond) then
+ Merge_Conditions (Cond, Class_Cond);
+ else
+ Class_Cond := Cond;
+ end if;
+
+ Check_Class_Condition
+ (Cond => Class_Cond,
+ Subp => Spec_Id,
+ Par_Subp => Subp_Id,
+ Is_Precondition => Kind in Ignored_Class_Precondition
+ | Class_Precondition);
+ Build_Class_Wide_Expression
+ (Pragma_Or_Expr => Class_Cond,
+ Subp => Spec_Id,
+ Par_Subp => Subp_Id,
+ Adjust_Sloc => False);
+
+ -- We are done as soon as we process the nearest ancestor
+
+ exit;
+ end if;
+ end if;
+ end loop;
+
+ -- Process the contract of interface primitives not covered by
+ -- the nearest ancestor.
+
+ for Index in Subps'Range loop
+ Subp_Id := Subps (Index);
+
+ if Is_Interface (Find_Dispatching_Type (Subp_Id)) then
+ if Present (Alias (Subp_Id)) then
+ Subp_Id := Ultimate_Alias (Subp_Id);
+ end if;
+
+ if not Seen_Subp (Subp_Id)
+ and then Present (Class_Condition (Kind, Subp_Id))
+ and then not Contains (Par_Iface_Prims, Subp_Id)
+ then
+ Seen (Index) := Subp_Id;
+
+ Cond := Inherit_Condition
+ (Subp => Spec_Id,
+ Par_Subp => Subp_Id);
+
+ Check_Class_Condition
+ (Cond => Cond,
+ Subp => Spec_Id,
+ Par_Subp => Subp_Id,
+ Is_Precondition => Kind in Ignored_Class_Precondition
+ | Class_Precondition);
+ Build_Class_Wide_Expression
+ (Pragma_Or_Expr => Cond,
+ Subp => Spec_Id,
+ Par_Subp => Subp_Id,
+ Adjust_Sloc => False);
+
+ if Present (Class_Cond) then
+ Merge_Conditions (Cond, Class_Cond);
+ else
+ Class_Cond := Cond;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ Set_Class_Condition (Kind, Spec_Id, Class_Cond);
+ end Process_Inherited_Conditions;
+
+ -- Local variables
+
+ Cond : Node_Id;
+
+ -- Start of processing for Merge_Class_Conditions
+
+ begin
+ for Kind in Condition_Kind loop
+ Cond := Class_Condition (Kind, Spec_Id);
+
+ -- If this subprogram has class-wide conditions then preanalyze
+ -- them before processing inherited conditions since conditions
+ -- are checked and merged from right to left.
+
+ if Present (Cond) then
+ Preanalyze_Condition (Spec_Id, Cond);
+ end if;
+
+ Process_Inherited_Conditions (Kind);
+
+ -- Preanalyze merged inherited conditions
+
+ if Cond /= Class_Condition (Kind, Spec_Id) then
+ Preanalyze_Condition (Spec_Id,
+ Class_Condition (Kind, Spec_Id));
+ end if;
+ end loop;
+ end Merge_Class_Conditions;
+
----------------------------------------
-- Save_Global_References_In_Contract --
----------------------------------------
@@ -3622,10 +4731,9 @@
------------------------------------
procedure Save_Global_References_In_List (First_Prag : Node_Id) is
- Prag : Node_Id;
+ Prag : Node_Id := First_Prag;
begin
- Prag := First_Prag;
while Present (Prag) loop
if Is_Generic_Contract_Pragma (Prag) then
Save_Global_References (Prag);
@@ -3662,4 +4770,29 @@
Pop_Scope;
end Save_Global_References_In_Contract;
+ -------------------------
+ -- Set_Class_Condition --
+ -------------------------
+
+ procedure Set_Class_Condition
+ (Kind : Condition_Kind;
+ Subp : Entity_Id;
+ Cond : Node_Id)
+ is
+ begin
+ case Kind is
+ when Class_Postcondition =>
+ Set_Class_Postconditions (Subp, Cond);
+
+ when Class_Precondition =>
+ Set_Class_Preconditions (Subp, Cond);
+
+ when Ignored_Class_Postcondition =>
+ Set_Ignored_Class_Postconditions (Subp, Cond);
+
+ when Ignored_Class_Precondition =>
+ Set_Ignored_Class_Preconditions (Subp, Cond);
+ end case;
+ end Set_Class_Condition;
+
end Contracts;
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index bfd482e..eb26ebf 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -216,6 +216,31 @@
-- subprogram declaration template denoted by Templ. The instantiated
-- pragmas are added to list L.
+ procedure Make_Class_Precondition_Subps
+ (Subp_Id : Entity_Id;
+ Late_Overriding : Boolean := False);
+ -- Build helpers that at run time evaluate statically and dynamically the
+ -- class-wide preconditions of Subp_Id; build also the indirect-call
+ -- wrapper (ICW) required to check class-wide preconditions when the
+ -- subprogram is invoked through an access-to-subprogram, or when it
+ -- overrides an inherited class-wide precondition (see AI12-0195-1).
+ -- Late_Overriding enables special handling required for late-overriding
+ -- subprograms.
+
+ procedure Merge_Class_Conditions (Spec_Id : Entity_Id);
+ -- Merge and preanalyze all class-wide conditions of Spec_Id (class-wide
+ -- preconditions merged with operator or-else; class-wide postconditions
+ -- merged with operator and-then). Ignored pre/postconditions are also
+ -- merged since, although they are not required to generate code, their
+ -- preanalysis is required to perform semantic checks. Resulting merged
+ -- expressions are later installed by the expander in helper subprograms
+ -- which are invoked from the caller side; they are also used to build
+ -- the dispatch-table wrapper (DTW), if required.
+
+ procedure Process_Class_Conditions_At_Freeze_Point (Typ : Entity_Id);
+ -- Merge, preanalyze, and check class-wide pre/postconditions of Typ
+ -- primitives.
+
procedure Save_Global_References_In_Contract
(Templ : Node_Id;
Gen_Id : Entity_Id);
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 5245feb3..8873000 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -112,7 +112,7 @@
-- d.y Disable implicit pragma Elaborate_All on task bodies
-- d.z Restore previous support for frontend handling of Inline_Always
- -- d.A
+ -- d.A Enable statistics printing in Atree
-- d.B Generate a bug box on abort_statement
-- d.C Generate concatenation call, do not generate inline code
-- d.D Disable errors on use of overriding keyword in Ada 95 mode
@@ -158,7 +158,7 @@
-- d_q
-- d_r
-- d_s Stop elaboration checks on synchronous suspension
- -- d_t
+ -- d_t In LLVM-based CCG, dump LLVM IR after transformations are done
-- d_u
-- d_v Enable additional checks and debug printouts in Atree
-- d_w
@@ -210,7 +210,7 @@
-- d.5 Do not generate imported subprogram definitions in C code
-- d.6 Do not avoid declaring unreferenced types in C code
-- d.7 Disable unsound heuristics in gnat2scil (for CP as SPARK prover)
- -- d.8
+ -- d.8 Disable unconditional inlining of expression functions
-- d.9 Disable build-in-place for nonlimited types
-- d_1
@@ -830,6 +830,11 @@
-- handling of Inline_Always by the front end on such targets. For the
-- targets that do not use the GCC back end, this switch is ignored.
+ -- d.A Enable statistics printing in Atree. First set Statistics_Enabled
+ -- in gen_il-gen.adb to True, then rebuild, then run the compiler
+ -- with -gnatd.A. You might want to apply "sort -nr" to parts of the
+ -- output.
+
-- d.B Generate a bug box when we see an abort_statement, even though
-- there is no bug. Useful for testing Comperr.Compiler_Abort: write
-- some code containing an abort_statement, and compile it with
@@ -992,6 +997,10 @@
-- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True
-- or Ada.Synchronous_Barriers.Wait_For_Release.
+ -- d_t In the LLVM-based CCG, do an additional dump of the LLVM IR
+ -- after the pass that does transformations to the IR into a
+ -- filename ending with .trans.ll.
+
-- d_v Enable additional checks and debug printouts in Atree
-- d_x The compiler does not expand in line the Image attribute for user-
@@ -1101,6 +1110,10 @@
-- issues (e.g., assuming that a low bound of an array parameter
-- of an unconstrained subtype belongs to the index subtype).
+ -- d.8 By default calls to expression functions are always inlined.
+ -- This debug flag turns off this behavior, making them subject
+ -- to the usual inlining heuristics of the code generator.
+
-- d.9 Disable build-in-place for function calls returning nonlimited
-- types.
diff --git a/gcc/ada/doc/gnat_rm.rst b/gcc/ada/doc/gnat_rm.rst
index 97f7e4d..7743ef8 100644
--- a/gcc/ada/doc/gnat_rm.rst
+++ b/gcc/ada/doc/gnat_rm.rst
@@ -55,6 +55,7 @@
gnat_rm/specialized_needs_annexes
gnat_rm/implementation_of_specific_ada_features
gnat_rm/implementation_of_ada_2012_features
+ gnat_rm/security_hardening_features
gnat_rm/obsolescent_features
gnat_rm/compatibility_and_porting_guide
diff --git a/gcc/ada/doc/gnat_rm/about_this_guide.rst b/gcc/ada/doc/gnat_rm/about_this_guide.rst
index b48785e..9defee8 100644
--- a/gcc/ada/doc/gnat_rm/about_this_guide.rst
+++ b/gcc/ada/doc/gnat_rm/about_this_guide.rst
@@ -96,6 +96,9 @@
* :ref:`Implementation_of_Ada_2012_Features`, describes the status of the
GNAT implementation of the Ada 2012 language standard.
+* :ref:`Security_Hardening_Features` documents GNAT extensions aimed
+ at security hardening.
+
* :ref:`Obsolescent_Features` documents implementation dependent features,
including pragmas and attributes, which are considered obsolescent, since
there are other preferred ways of achieving the same results. These
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
index 8d0be38..c5c7dfb 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_characteristics.rst
@@ -53,7 +53,8 @@
See separate section on source representation.
*
- "The control functions allowed in comments. See 2.1(14)."
+ "The semantics of an Ada program whose text is not in
+ Normalization Form C. See 2.1(4)."
See separate section on source representation.
@@ -86,14 +87,14 @@
not.
*
- "The sequence of characters of the value returned by
- ``S'Image`` when some of the graphic characters of
- ``S'Wide_Image`` are not defined in ``Character``. See
- 3.5(37)."
+ "The message string associated with the Assertion_Error exception raised
+ by the failure of a predicate check if there is no applicable
+ Predicate_Failure aspect. See 3.2.4(31)."
-The sequence of characters is as defined by the wide character encoding
-method used for the source. See section on source representation for
-further details.
+In the case of a Dynamic_Predicate aspect, the string is
+"Dynamic_Predicate failed at <source position>", where
+"<source position>" might be something like "foo.adb:123".
+The Static_Predicate case is handled analogously.
*
"The predefined integer types declared in
@@ -146,12 +147,12 @@
IEEE 80-bit Extended on x86 architecture
====================== ===============================================
-The default rounding mode specified by the IEEE 754 Standard is assumed for
-static computations, i.e. round to nearest, ties to even. The input routines
-yield correctly rounded values for Short_Float, Float and Long_Float at least.
-The output routines can compute up to twice as many exact digits as the value
-of ``T'Digits`` for any type, for example 30 digits for Long_Float; if more
-digits are requested, zeros are printed.
+The default rounding mode specified by the IEEE 754 Standard is assumed both
+for static and dynamic computations (that is, round to nearest, ties to even).
+The input routines yield correctly rounded values for Short_Float, Float, and
+Long_Float at least. The output routines can compute up to twice as many exact
+digits as the value of ``T'Digits`` for any type, for example 30 digits for
+Long_Float; if more digits are requested, zeros are printed.
*
"The small of an ordinary fixed point type. See 3.5.9(8)."
@@ -192,24 +193,79 @@
decimal integer are allocated.
*
+ "The sequence of characters of the value returned by Tags.Expanded_Name
+ (respectively, Tags.Wide_Expanded_Name) when some of the graphic
+ characters of Tags.Wide_Wide_Expanded_Name are not defined in Character
+ (respectively, Wide_Character). See 3.9(10.1)."
+
+This is handled in the same way as the implementation-defined behavior
+referenced in A.4.12(34).
+
+*
"Implementation-defined attributes. See 4.1.4(12)."
See :ref:`Implementation_Defined_Attributes`.
*
+ "The value of the parameter to Empty for some container aggregates.
+ See 4.3.5(40)."
+
+As per the suggestion given in the Annotated Ada RM, the default value
+of the formal parameter is used if one exists and zero is used otherwise.
+
+*
+ "The maximum number of chunks for a parallel reduction expression without
+ a chunk_specification. See 4.5.10(21)."
+
+Feature unimplemented.
+
+*
+ "Rounding of real static expressions which are exactly half-way between
+ two machine numbers. See 4.9(38)."
+
+Round to even is used in all such cases.
+
+*
+ "The maximum number of chunks for a parallel generalized iterator without
+ a chunk_specification. See 5.5.2(10)."
+
+Feature unimplemented.
+
+*
+ "The number of chunks for an array component iterator. See 5.5.2(11)."
+
+Feature unimplemented.
+
+*
+ "Any extensions of the Global aspect. See 6.1.2(43)."
+
+Feature unimplemented.
+
+*
+ "The circumstances the implementation passes in the null value for a view
+ conversion of an access type used as an out parameter. See 6.4.1(19)."
+
+Difficult to characterize.
+
+*
+ "Any extensions of the Default_Initial_Condition aspect. See 7.3.3(11)."
+
+SPARK allows specifying *null* as the Default_Initial_Condition
+aspect of a type. See the SPARK reference manual for further details.
+
+*
"Any implementation-defined time types. See 9.6(6)."
There are no implementation-defined time types.
*
- "The time base associated with relative delays."
+ "The time base associated with relative delays. See 9.6(20)."
See 9.6(20). The time base used is that provided by the C library
function ``gettimeofday``.
*
- "The time base of the type ``Calendar.Time``. See
- 9.6(23)."
+ "The time base of the type ``Calendar.Time``. See 9.6(23)."
The time base used is that provided by the C library function
``gettimeofday``.
@@ -229,13 +285,15 @@
There are no such limits.
*
- "Whether or not two non-overlapping parts of a composite
- object are independently addressable, in the case where packing, record
- layout, or ``Component_Size`` is specified for the object. See
- 9.10(1)."
+ "The result of Calendar.Formatting.Image if its argument represents more
+ than 100 hours. See 9.6.1(86)."
-Separate components are independently addressable if they do not share
-overlapping storage units.
+Calendar.Time_Error is raised.
+
+*
+ "Implementation-defined conflict check policies. See 9.10.1(5)."
+
+There are no implementation-defined conflict check policies.
*
"The representation for a compilation. See 10.1(2)."
@@ -281,9 +339,8 @@
:title:`GNAT User's Guide`.
*
- "The implementation-defined means, if any, of specifying
- which compilation units are needed by a given compilation unit. See
- 10.2(2)."
+ "The implementation-defined means, if any, of specifying which compilation
+ units are needed by a given compilation unit. See 10.2(2)."
The units needed by a given compilation unit are as defined in
the Ada Reference Manual section 10.2(2-6). There are no
@@ -298,17 +355,13 @@
corresponding :file:`ALI` file as the input parameter to the binder.
*
- "The order of elaboration of *library_items*. See
- 10.2(18)."
+ "The order of elaboration of *library_items*. See 10.2(18)."
The first constraint on ordering is that it meets the requirements of
Chapter 10 of the Ada Reference Manual. This still leaves some
-implementation dependent choices, which are resolved by first
-elaborating bodies as early as possible (i.e., in preference to specs
-where there is a choice), and second by evaluating the immediate with
-clauses of a unit to determine the probably best choice, and
-third by elaborating in alphabetical order of unit names
-where a choice still remains.
+implementation-dependent choices, which are resolved by analyzing
+the elaboration code of each unit and identifying implicit
+elaboration-order dependencies.
*
"Parameter passing and function return for the main
@@ -320,13 +373,12 @@
may have been set by a call to ``Ada.Command_Line.Set_Exit_Status``).
*
- "The mechanisms for building and running partitions. See
- 10.2(24)."
+ "The mechanisms for building and running partitions. See 10.2(24)."
-GNAT itself supports programs with only a single partition. The GNATDIST
+GNAT itself supports programs with only a single partition. The GNATDIST
tool provided with the GLADE package (which also includes an implementation
of the PCS) provides a completely flexible method for building and running
-programs consisting of multiple partitions. See the separate GLADE manual
+programs consisting of multiple partitions. See the separate GLADE manual
for details.
*
@@ -340,12 +392,11 @@
implementation. See 10.2(28)."
Passive partitions are supported on targets where shared memory is
-provided by the operating system. See the GLADE reference manual for
+provided by the operating system. See the GLADE reference manual for
further details.
*
- "The information returned by ``Exception_Message``. See
- 11.4.1(10)."
+ "The information returned by ``Exception_Message``. See 11.4.1(10)."
Exception message returns the null string unless a specific message has
been passed by the program.
@@ -391,6 +442,38 @@
the last line is a single ``LF`` character (``16#0A#``).
*
+ "The sequence of characters of the value returned by
+ Exceptions.Exception_Name (respectively, Exceptions.Wide_Exception_Name)
+ when some of the graphic characters of Exceptions.Wide_Wide_Exception_Name
+ are not defined in Character (respectively, Wide_Character).
+ See 11.4.1(12.1)."
+
+This is handled in the same way as the implementation-defined behavior
+referenced in A.4.12(34).
+
+*
+ "The information returned by Exception_Information. See 11.4.1(13)."
+
+The exception name and the source location at which the exception was
+raised are included.
+
+*
+ "Implementation-defined policy_identifiers and assertion_aspect_marks
+ allowed in a pragma Assertion_Policy. See 11.4.2(9)."
+
+Implementation-defined assertion_aspect_marks include Assert_And_Cut,
+Assume, Contract_Cases, Debug, Ghost, Initial_Condition, Loop_Invariant,
+Loop_Variant, Postcondition, Precondition, Predicate, Refined_Post,
+Statement_Assertions, and Subprogram_Variant. Implementation-defined
+policy_identifiers include Ignore and Suppressible.
+
+*
+ "The default assertion policy. See 11.4.2(10)."
+
+The default assertion policy is Ignore, although this can be overridden
+via compiler switches such as "-gnata".
+
+*
"Implementation-defined check names. See 11.5(27)."
The implementation defined check names include Alignment_Check,
@@ -400,28 +483,54 @@
Check_Name. See the description of pragma ``Suppress`` for full details.
*
- "The interpretation of each aspect of representation. See
- 13.1(20)."
+ "Existence and meaning of second parameter of pragma Unsuppress.
+ See 11.5(27.1)."
+
+The legality rules for and semantics of the second parameter of pragma
+Unsuppress match those for the second argument of pragma Suppress.
+
+*
+ "The cases that cause conflicts between the representation of the
+ ancestors of a type_declaration. See 13.1(13.1)."
+
+No such cases exist.
+
+*
+ "The interpretation of each representation aspect. See 13.1(20)."
See separate section on data representations.
*
- "Any restrictions placed upon representation items. See
- 13.1(20)."
+ "Any restrictions placed upon the specification of representation aspects.
+ See 13.1(20)."
See separate section on data representations.
*
- "The meaning of ``Size`` for indefinite subtypes. See
- 13.3(48)."
+ "Implementation-defined aspects, including the syntax for specifying
+ such aspects and the legality rules for such aspects. See 13.1.1(38)."
-Size for an indefinite subtype is the maximum possible size, except that
-for the case of a subprogram parameter, the size of the parameter object
-is the actual size.
+See :ref:`Implementation_Defined_Aspects`.
*
- "The default external representation for a type tag. See
- 13.3(75)."
+ "The set of machine scalars. See 13.3(8.1)."
+
+See separate section on data representations.
+
+*
+ "The meaning of ``Size`` for indefinite subtypes. See 13.3(48)."
+
+The Size attribute of an indefinite subtype is not less than the Size
+attribute of any object of that type.
+
+*
+ "The meaning of Object_Size for indefinite subtypes. See 13.3(58)."
+
+The Object_Size attribute of an indefinite subtype is not less than the
+Object_Size attribute of any object of that type.
+
+*
+ "The default external representation for a type tag. See 13.3(75)."
The default external representation for a type tag is the fully expanded
name of the type in upper case letters.
@@ -448,12 +557,10 @@
bit ordering corresponds to the natural endianness of the target architecture.
*
- "The contents of the visible part of package ``System``
- and its language-defined children. See 13.7(2)."
+ "The contents of the visible part of package ``System``. See 13.7(2)."
-See the definition of these packages in files :file:`system.ads` and
-:file:`s-stoele.ads`. Note that two declarations are added to package
-System.
+See the definition of package System in :file:`system.ads`.
+Note that two declarations are added to package System.
.. code-block:: ada
@@ -461,14 +568,21 @@
Max_Interrupt_Priority : constant Positive := Interrupt_Priority'Last;
*
- "The contents of the visible part of package
- ``System.Machine_Code``, and the meaning of
- *code_statements*. See 13.8(7)."
+ "The range of Storage_Elements.Storage_Offset, the modulus of
+ Storage_Elements.Storage_Element, and the declaration of
+ Storage_Elements.Integer_Address. See 13.7.1(11)."
+
+See the definition of package System.Storage_Elements in :file:`s-stoele.ads`.
+
+*
+ "The contents of the visible part of package ``System.Machine_Code``,
+ and the meaning of *code_statements*. See 13.8(7)."
See the definition and documentation in file :file:`s-maccod.ads`.
*
- "The effect of unchecked conversion. See 13.9(11)."
+ "The result of unchecked conversion for instances with scalar result
+ types whose result is not defined by the language. See 13.9(11)."
Unchecked conversion between types of the same size
results in an uninterpreted transmission of the bits from one type
@@ -485,69 +599,43 @@
made with appropriate alignment
*
- "The semantics of operations on invalid representations.
- See 13.9.2(10-11)."
+ "The result of unchecked conversion for instances with nonscalar result
+ types whose result is not defined by the language. See 13.9(11)."
-For assignments and other operations where the use of invalid values cannot
-result in erroneous behavior, the compiler ignores the possibility of invalid
-values. An exception is raised at the point where an invalid value would
-result in erroneous behavior. For example executing:
-
-.. code-block:: ada
-
- procedure invalidvals is
- X : Integer := -1;
- Y : Natural range 1 .. 10;
- for Y'Address use X'Address;
- Z : Natural range 1 .. 10;
- A : array (Natural range 1 .. 10) of Integer;
- begin
- Z := Y; -- no exception
- A (Z) := 3; -- exception raised;
- end;
-
-As indicated, an exception is raised on the array assignment, but not
-on the simple assignment of the invalid negative value from Y to Z.
-
-*
- "The manner of choosing a storage pool for an access type
- when ``Storage_Pool`` is not specified for the type. See 13.11(17)."
-
-There are 3 different standard pools used by the compiler when
-``Storage_Pool`` is not specified depending whether the type is local
-to a subprogram or defined at the library level and whether
-``Storage_Size``is specified or not. See documentation in the runtime
-library units ``System.Pool_Global``, ``System.Pool_Size`` and
-``System.Pool_Local`` in files :file:`s-poosiz.ads`,
-:file:`s-pooglo.ads` and :file:`s-pooloc.ads` for full details on the
-default pools used.
+See preceding definition for the scalar result case.
*
"Whether or not the implementation provides user-accessible
names for the standard pool type(s). See 13.11(17)."
-See documentation in the sources of the run time mentioned in the previous
-paragraph. All these pools are accessible by means of `with`\ ing
+There are 3 different standard pools used by the compiler when
+``Storage_Pool`` is not specified depending whether the type is local
+to a subprogram or defined at the library level and whether
+``Storage_Size``is specified or not. See documentation in the runtime
+library units ``System.Pool_Global``, ``System.Pool_Size`` and
+``System.Pool_Local`` in files :file:`s-poosiz.ads`,
+:file:`s-pooglo.ads` and :file:`s-pooloc.ads` for full details on the
+default pools used. All these pools are accessible by means of `with`\ ing
these units.
*
- "The meaning of ``Storage_Size``. See 13.11(18)."
+ "The meaning of ``Storage_Size`` when neither the Storage_Size nor the
+ Storage_Pool is specified for an access type. See 13.11(18)."
``Storage_Size`` is measured in storage units, and refers to the
total space available for an access type collection, or to the primary
stack space for a task.
*
- "Implementation-defined aspects of storage pools. See
- 13.11(22)."
+ "The effect of specifying aspect Default_Storage_Pool on an instance
+ of a language-defined generic unit. See 13.11.3(5)."
-See documentation in the sources of the run time mentioned in the
-paragraph about standard storage pools above
-for details on GNAT-defined aspects of storage pools.
+Instances of language-defined generic units are treated the same as other
+instances with respect to the Default_Storage_Pool aspect.
*
- "The set of restrictions allowed in a pragma
- ``Restrictions``. See 13.12(7)."
+ "Implementation-defined restrictions allowed in a pragma
+ ``Restrictions``. See 13.12(8.7)."
See :ref:`Standard_and_Implementation_Defined_Restrictions`.
@@ -555,14 +643,19 @@
"The consequences of violating limitations on
``Restrictions`` pragmas. See 13.12(9)."
-Restrictions that can be checked at compile time result in illegalities
-if violated. Currently there are no other consequences of violating
-restrictions.
+Restrictions that can be checked at compile time are enforced at
+compile time; violations are illegal. For other restrictions, any
+violation during program execution results in erroneous execution.
*
- "The representation used by the ``Read`` and
- ``Write`` attributes of elementary types in terms of stream
- elements. See 13.13.2(9)."
+ "Implementation-defined usage profiles allowed in a pragma Profile.
+ See 13.12(15)."
+
+See :ref:`Implementation_Defined_Pragmas`.
+
+*
+ "The contents of the stream elements read and written by the Read and
+ Write attributes of elementary types. See 13.13.2(9)."
The representation is the in-memory representation of the base type of
the type, using the number of bits corresponding to the
@@ -575,12 +668,29 @@
See items describing the integer and floating-point types supported.
*
- "The string returned by ``Character_Set_Version``.
- See A.3.5(3)."
+ "The values returned by Strings.Hash. See A.4.9(3)."
-``Ada.Wide_Characters.Handling.Character_Set_Version`` returns
-the string "Unicode 4.0", referring to version 4.0 of the
-Unicode specification.
+This hash function has predictable collisions and is subject to
+equivalent substring attacks. It is not suitable for construction of a
+hash table keyed on possibly malicious user input.
+
+*
+ "The value returned by a call to a Text_Buffer Get procedure if any
+ character in the returned sequence is not defined in Character.
+ See A.4.12(34)."
+
+The contents of a buffer is represented internally as a UTF_8 string.
+The value return by Text_Buffer.Get is the result of passing that
+UTF_8 string to UTF_Encoding.Strings.Decode.
+
+*
+ "The value returned by a call to a Text_Buffer Wide_Get procedure if
+ any character in the returned sequence is not defined in Wide_Character.
+ See A.4.12(34)."
+
+The contents of a buffer is represented internally as a UTF_8 string.
+The value return by Text_Buffer.Wide_Get is the result of passing that
+UTF_8 string to UTF_Encoding.Wide_Strings.Decode.
*
"The accuracy actually achieved by the elementary
@@ -610,14 +720,6 @@
Maximum image width is 6864, see library file :file:`s-rannum.ads`.
*
- "The algorithms for random number generation. See
- A.5.2(32)."
-
-The algorithm is the Mersenne Twister, as documented in the source file
-:file:`s-rannum.adb`. This version of the algorithm has a period of
-2**19937-1.
-
-*
"The string representation of a random number generator's
state. See A.5.2(38)."
@@ -626,32 +728,16 @@
of the state vector.
*
- "The minimum time interval between calls to the
- time-dependent Reset procedure that are guaranteed to initiate different
- random number sequences. See A.5.2(45)."
-
-The minimum period between reset calls to guarantee distinct series of
-random numbers is one microsecond.
-
-*
"The values of the ``Model_Mantissa``,
``Model_Emin``, ``Model_Epsilon``, ``Model``,
``Safe_First``, and ``Safe_Last`` attributes, if the Numerics
Annex is not supported. See A.5.3(72)."
-Run the compiler with *-gnatS* to produce a listing of package
-``Standard``, has the values of all numeric attributes.
+Running the compiler with *-gnatS* to produce a listing of package
+``Standard`` displays the values of these attributes.
*
- "Any implementation-defined characteristics of the
- input-output packages. See A.7(14)."
-
-There are no special implementation defined characteristics for these
-packages.
-
-*
- "The value of ``Buffer_Size`` in ``Storage_IO``. See
- A.9(10)."
+ "The value of ``Buffer_Size`` in ``Storage_IO``. See A.9(10)."
All type representations are contiguous, and the ``Buffer_Size`` is
the value of ``type'Size`` rounded up to the next storage unit
@@ -662,17 +748,22 @@
standard error See A.10(5)."
These files are mapped onto the files provided by the C streams
-libraries. See source file :file:`i-cstrea.ads` for further details.
+libraries. See source file :file:`i-cstrea.ads` for further details.
*
- "The accuracy of the value produced by ``Put``. See
- A.10.9(36)."
+ "The accuracy of the value produced by ``Put``. See A.10.9(36)."
If more digits are requested in the output than are represented by the
precision of the value, zeroes are output in the corresponding least
significant digit positions.
*
+ "Current size for a stream file for which positioning is not supported.
+ See A.12.1(1.1)."
+
+Positioning is supported.
+
+*
"The meaning of ``Argument_Count``, ``Argument``, and
``Command_Name``. See A.15(1)."
@@ -680,74 +771,30 @@
main program in the natural manner.
*
- "The interpretation of the ``Form`` parameter in procedure
- ``Create_Directory``. See A.16(56)."
+ "The interpretation of file names and directory names. See A.16(46)."
-The ``Form`` parameter is not used.
+These names are interpreted consistently with the underlying file system.
*
- "The interpretation of the ``Form`` parameter in procedure
- ``Create_Path``. See A.16(60)."
+ "The maxium value for a file size in Directories. See A.16(87)."
-The ``Form`` parameter is not used.
+Directories.File_Size'Last is equal to Long_Long_Integer'Last .
*
- "The interpretation of the ``Form`` parameter in procedure
- ``Copy_File``. See A.16(68)."
+ "The result for Directories.Size for a directory or special file.
+ See A.16(93)."
-The ``Form`` parameter is case-insensitive.
-Two fields are recognized in the ``Form`` parameter::
-
- *preserve=<value>*
- *mode=<value>*
-
-<value> starts immediately after the character '=' and ends with the
-character immediately preceding the next comma (',') or with the last
-character of the parameter.
-
-The only possible values for preserve= are:
-
-================== ===================================================================
-Value Meaning
-================== ===================================================================
-*no_attributes* Do not try to preserve any file attributes. This is the
- default if no preserve= is found in Form.
-*all_attributes* Try to preserve all file attributes (timestamps, access rights).
-*timestamps* Preserve the timestamp of the copied file, but not the other
- file attributes.
-================== ===================================================================
-
-The only possible values for mode= are:
-
-============== ===============================================================================
-Value Meaning
-============== ===============================================================================
-*copy* Only do the copy if the destination file does not already exist.
- If it already exists, Copy_File fails.
-*overwrite* Copy the file in all cases. Overwrite an already existing destination file.
-*append* Append the original file to the destination file. If the destination file
- does not exist, the destination file is a copy of the source file.
- When mode=append, the field preserve=, if it exists, is not taken into account.
-============== ===============================================================================
-
-If the Form parameter includes one or both of the fields and the value or
-values are incorrect, Copy_file fails with Use_Error.
-
-Examples of correct Forms::
-
- Form => "preserve=no_attributes,mode=overwrite" (the default)
- Form => "mode=append"
- Form => "mode=copy, preserve=all_attributes"
-
-Examples of incorrect Forms::
-
- Form => "preserve=junk"
- Form => "mode=internal, preserve=timestamps"
+Name_Error is raised.
*
- "The interpretation of the ``Pattern`` parameter, when not the null string,
- in the ``Start_Search`` and ``Search`` procedures.
- See A.16(104) and A.16(112)."
+ "The result for Directories.Modification_Time for a directory or special file.
+ See A.16(93)."
+
+Name_Error is raised.
+
+*
+ "The interpretation of a nonnull search pattern in Directories.
+ See A.16(104)."
When the ``Pattern`` parameter is not the null string, it is interpreted
according to the syntax of regular expressions as defined in the
@@ -756,6 +803,36 @@
See :ref:`GNAT.Regexp_(g-regexp.ads)`.
*
+ "The results of a Directories search if the contents of the directory are
+ altered while a search is in progress. See A.16(110)."
+
+The effect of a call to Get_Next_Entry is determined by the current
+state of the directory.
+
+*
+ "The definition and meaning of an environment variable. See A.17(1)."
+
+This definition is determined by the underlying operating system.
+
+*
+ "The circumstances where an environment variable cannot be defined.
+ See A.17(16)."
+
+ There are no such implementation-defined circumstances.
+
+*
+ "Environment names for which Set has the effect of Clear. See A.17(17)."
+
+There are no such names.
+
+*
+ "The value of Containers.Hash_Type'Modulus. The value of
+ Containers.Count_Type'Last. See A.18.1(7)."
+
+Containers.Hash_Type'Modulus is 2**32.
+Containers.Count_Type'Last is 2**31 - 1.
+
+*
"Implementation-defined convention names. See B.1(11)."
The following convention names are supported
@@ -806,9 +883,8 @@
Link names are the actual names used by the linker.
*
- "The manner of choosing link names when neither the link
- name nor the address of an imported or exported entity is specified. See
- B.1(36)."
+ "The manner of choosing link names when neither the link name nor the
+ address of an imported or exported entity is specified. See B.1(36)."
The default linker name is that which would be assigned by the relevant
external language, interpreting the Ada name as being in all lower case
@@ -845,6 +921,12 @@
See files with prefix :file:`i-` in the distributed library.
*
+ "The definitions of certain types and constants in Interfaces.C.
+ See B.3(41)."
+
+See source file :file:`i-c.ads`.
+
+*
"The types ``Floating``, ``Long_Floating``,
``Binary``, ``Long_Binary``, ``Decimal_ Element``, and
``COBOL_Character``; and the initialization of the variables
@@ -865,45 +947,54 @@
For initialization, see the file :file:`i-cobol.ads` in the distributed library.
*
- "Support for access to machine instructions. See C.1(1)."
+ "The types Fortran_Integer, Real, Double_Precision, and Character_Set
+ in Interfaces.Fortran. See B.5(17)."
-See documentation in file :file:`s-maccod.ads` in the distributed library.
+See source file :file:`i-fortra.ads`. These types are derived, respectively,
+from Integer, Float, Long_Float, and Character.
*
- "Implementation-defined aspects of access to machine
- operations. See C.1(9)."
+ "Implementation-defined intrinsic subprograms. See C.1(1)."
-See documentation in file :file:`s-maccod.ads` in the distributed library.
+See separate section on Intrinsic Subprograms.
*
- "Implementation-defined aspects of interrupts. See C.3(2)."
+ "Any restrictions on a protected procedure or its containing type when an
+ aspect Attach_handler or Interrupt_Handler is specified. See C.3.1(17)."
-Interrupts are mapped to signals or conditions as appropriate. See
-definition of unit
-``Ada.Interrupt_Names`` in source file :file:`a-intnam.ads` for details
-on the interrupts supported on a particular target.
+There are no such restrictions.
*
- "Implementation-defined aspects of pre-elaboration. See
- C.4(13)."
+ "Any other forms of interrupt handler supported by the Attach_Handler and
+ Interrupt_Handler aspects. See C.3.1(19)."
-GNAT does not permit a partition to be restarted without reloading,
-except under control of the debugger.
+There are no such forms.
*
- "The semantics of pragma ``Discard_Names``. See C.5(7)."
+ "The semantics of some attributes and functions of an entity for which
+ aspect Discard_Names is True. See C.5(7)."
-Pragma ``Discard_Names`` causes names of enumeration literals to
-be suppressed. In the presence of this pragma, the Image attribute
+If Discard_Names is True for an enumeration type, the Image attribute
provides the image of the Pos of the literal, and Value accepts
Pos values.
-For tagged types, when pragmas ``Discard_Names`` and ``No_Tagged_Streams``
-simultaneously apply, their Expanded_Name and External_Tag are initialized
-with empty strings. This is useful to avoid exposing entity names at binary
+If both of the aspects``Discard_Names`` and ``No_Tagged_Streams`` are true
+for a tagged type, its Expanded_Name and External_Tag values are
+empty strings. This is useful to avoid exposing entity names at binary
level.
*
+ "The modulus and size of Test_and_Set_Flag. See C.6.3(8)."
+
+The modulus is 2**8. The size is 8.
+
+*
+ "The value used to represent the set value for Atomic_Test_and_Set.
+ See C.6.3(10)."
+
+The value is 1.
+
+*
"The result of the ``Task_Identification.Image``
attribute. See C.7.1(7)."
@@ -939,32 +1030,11 @@
convenient thread, so the value of ``Current_Task`` is undefined.
*
- "The effect of calling ``Current_Task`` from an entry
- body or interrupt handler. See C.7.1(19)."
+ "Granularity of locking for Task_Attributes. See C.7.2(16)."
-When GNAT can determine statically that ``Current_Task`` is called directly in
-the body of an entry (or barrier) then a warning is emitted and ``Program_Error``
-is raised at run time. Otherwise, the effect of calling ``Current_Task`` from an
-entry body or interrupt handler is to return the identification of the task
-currently executing the code.
-
-*
- "Implementation-defined aspects of
- ``Task_Attributes``. See C.7.2(19)."
-
-There are no implementation-defined aspects of ``Task_Attributes``.
-
-*
- "Values of all ``Metrics``. See D(2)."
-
-The metrics information for GNAT depends on the performance of the
-underlying operating system. The sources of the run-time for tasking
-implementation, together with the output from *-gnatG* can be
-used to determine the exact sequence of operating systems calls made
-to implement various tasking constructs. Together with appropriate
-information on the performance of the underlying operating system,
-on the exact target in use, this information can be used to determine
-the required metrics.
+No locking is needed if the formal type Attribute has the size and
+alignment of either Integer or System.Address and the bit representation
+of Initial_Value is all zeroes. Otherwise, locking is performed.
*
"The declarations of ``Any_Priority`` and
@@ -993,23 +1063,14 @@
underlying operating system.
*
- "Implementation-defined *policy_identifiers* allowed
- in a pragma ``Task_Dispatching_Policy``. See D.2.2(3)."
+ "Implementation-defined task dispatching policies. See D.2.2(3)."
-There are no implementation-defined policy-identifiers allowed in this
-pragma.
+There are no implementation-defined task dispatching policies.
*
- "Implementation-defined aspects of priority inversion. See
- D.2.2(16)."
+ "The value of Default_Quantum in Dispatching.Round_Robin. See D.2.5(4)."
-Execution of a task cannot be preempted by the implementation processing
-of delay expirations for lower priority tasks.
-
-*
- "Implementation-defined task dispatching. See D.2.2(18)."
-
-The policy is the same as that of the underlying threads implementation.
+The value is 10 milliseconds.
*
"Implementation-defined *policy_identifiers* allowed
@@ -1045,12 +1106,9 @@
There are no implementation-defined queuing policies.
*
- "On a multiprocessor, any conditions that cause the
- completion of an aborted construct to be delayed later than what is
- specified for a single processor. See D.6(3)."
+ "Implementation-defined admission policies. See D.4.1(1)."
-The semantics for abort on a multi-processor is the same as on a single
-processor, there are no further delays.
+There are no implementation-defined admission policies.
*
"Any operations that implicitly require heap storage
@@ -1060,43 +1118,75 @@
task creation.
*
- "What happens when a task terminates in the presence of
- pragma ``No_Task_Termination``. See D.7(15)."
+ "When restriction No_Dynamic_CPU_Assignment applies to a partition, the
+ processor on which a task with a CPU value of a Not_A_Specific_CPU will
+ execute. See D.7(10)."
+
+Unknown.
+
+*
+ "When restriction No_Task_Termination applies to a partition, what happens
+ when a task terminates. See D.7(15.1)."
Execution is erroneous in that case.
*
- "Implementation-defined aspects of pragma
- ``Restrictions``. See D.7(20)."
+ "The behavior when restriction Max_Storage_At_Blocking is violated.
+ See D.7(17)."
-There are no such implementation-defined aspects.
+Execution is erroneous in that case.
*
- "Implementation-defined aspects of package
- ``Real_Time``. See D.8(17)."
+ "The behavior when restriction Max_Asynchronous_Select_Nesting is violated.
+ See D.7(18)."
-There are no implementation defined aspects of package ``Real_Time``.
+Execution is erroneous in that case.
*
- "Implementation-defined aspects of
- *delay_statements*. See D.9(8)."
+ "The behavior when restriction Max_Tasks is violated. See D.7(19)."
-Any difference greater than one microsecond will cause the task to be
-delayed (see D.9(7)).
+Execution is erroneous in that case.
+
+* "Whether the use of pragma Restrictions results in a reduction in program
+ code or data size or execution time. See D.7(20)."
+
+ Yes it can, but the precise circumstances and properties of such reductions
+ are difficult to characterize.
*
- "The upper bound on the duration of interrupt blocking
- caused by the implementation. See D.12(5)."
+ "The value of Barrier_Limit'Last in Synchronous_Barriers. See D.10.1(4)."
-The upper bound is determined by the underlying operating system. In
-no cases is it more than 10 milliseconds.
+Synchronous_Barriers.Barrier_Limit'Last is Integer'Last .
+
+*
+ "When an aborted task that is waiting on a Synchronous_Barrier is aborted.
+ See D.10.1(13)."
+
+Difficult to characterize.
+
+*
+ "The value of Min_Handler_Ceiling in Execution_Time.Group_Budgets.
+ See D.14.2(7)."
+
+See source file :file:`a-etgrbu.ads`.
+
+*
+ "The value of CPU_Range'Last in System.Multiprocessors. See D.16(4)."
+
+See source file :file:`s-multip.ads`.
+
+*
+ "The processor on which the environment task executes in the absence
+ of a value for the aspect CPU. See D.16(13)."
+
+Unknown.
*
"The means for creating and executing distributed
programs. See E(5)."
The GLADE package provides a utility GNATDIST for creating and executing
-distributed programs. See the GLADE reference manual for further details.
+distributed programs. See the GLADE reference manual for further details.
*
"Any events that can result in a partition becoming
@@ -1105,24 +1195,13 @@
See the GLADE reference manual for full details on such events.
*
- "The scheduling policies, treatment of priorities, and
- management of shared resources between partitions in certain cases. See
- E.1(11)."
+ "The scheduling policies, treatment of priorities, and management of
+ shared resources between partitions in certain cases. See E.1(11)."
See the GLADE reference manual for full details on these aspects of
multi-partition execution.
*
- "Events that cause the version of a compilation unit to
- change. See E.3(5)."
-
-Editing the source file of a compilation unit, or the source files of
-any units on which it is dependent in a significant way cause the version
-to change. No other actions cause the version number to change. All changes
-are significant except those which affect only layout, capitalization or
-comments.
-
-*
"Whether the execution of the remote subprogram is
immediately aborted as a result of cancellation. See E.4(13)."
@@ -1130,14 +1209,12 @@
a distributed application.
*
- "Implementation-defined aspects of the PCS. See E.5(25)."
+ "The range of type System.RPC.Partition_Id. See E.5(14)."
-See the GLADE reference manual for a full description of all implementation
-defined aspects of the PCS.
+System.RPC.Partion_ID'Last is Integer'Last. See source file :file:`s-rpc.ads`.
*
- "Implementation-defined interfaces in the PCS. See
- E.5(26)."
+ "Implementation-defined interfaces in the PCS. See E.5(26)."
See the GLADE reference manual for a full description of all
implementation defined interfaces.
@@ -1228,9 +1305,8 @@
Not relevant, division is IEEE exact.
*
- "The definition of close result set, which determines the
- accuracy of certain fixed point multiplications and divisions. See
- G.2.3(5)."
+ "The definition of close result set, which determines the accuracy of
+ certain fixed point multiplications and divisions. See G.2.3(5)."
Operations in the close result set are performed using IEEE long format
floating-point arithmetic. The input operands are converted to
@@ -1291,28 +1367,20 @@
Information on those subjects is not yet available.
*
- "Information regarding bounded errors and erroneous
- execution. See H.2(1)."
+ "The accuracy requirements for the subprograms Solve, Inverse,
+ Determinant, Eigenvalues and Eigensystem for type Real_Matrix.
+ See G.3.1(81)."
-Information on this subject is not yet available.
+Information on those subjects is not yet available.
*
- "Implementation-defined aspects of pragma
- ``Inspection_Point``. See H.3.2(8)."
+ "The accuracy requirements for the subprograms Solve, Inverse,
+ Determinant, Eigenvalues and Eigensystem for type Complex_Matrix.
+ See G.3.2(149)."
-Pragma ``Inspection_Point`` ensures that the variable is live and can
-be examined by the debugger at the inspection point.
+Information on those subjects is not yet available.
*
- "Implementation-defined aspects of pragma
- ``Restrictions``. See H.4(25)."
+ "The consequences of violating No_Hidden_Indirect_Globals. See H.4(23.9)."
-There are no implementation-defined aspects of pragma ``Restrictions``. The
-use of pragma ``Restrictions [No_Exceptions]`` has no effect on the
-generated code. Checks must suppressed by use of pragma ``Suppress``.
-
-*
- "Any restrictions on pragma ``Restrictions``. See
- H.4(27)."
-
-There are no restrictions on pragma ``Restrictions``.
+Execution is erroneous in that case.
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 6c81ca7..0375982 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -2270,8 +2270,15 @@
values of the composite type shall be covered. The composite type of the
selector shall be a nonlimited untagged (but possibly discriminated)
record type, all of whose subcomponent subtypes are either static discrete
- subtypes or record types that meet the same restrictions. Support for arrays
- is planned, but not yet implemented.
+ subtypes or record types that meet the same restrictions.
+
+ Support for casing on arrays (and on records that contain arrays) is
+ currently subject to some restrictions. Non-positional
+ array aggregates are not supported as (or within) case choices. Likewise
+ for array type and subtype names. The current implementation exceeds
+ compile-time capacity limits in some annoyingly common scenarios; the
+ message generated in such cases is usually "Capacity exceeded in compiling
+ case statement with composite selector type".
In addition, pattern bindings are supported. This is a mechanism
for binding a name to a component of a matching value for use within
@@ -2280,7 +2287,8 @@
"is <identifier>". In the special case of a "box" component association,
the identifier may instead be provided within the box. Either of these
indicates that the given identifer denotes (a constant view of) the matching
- subcomponent of the case selector.
+ subcomponent of the case selector. Binding is not yet supported for arrays
+ or subcomponents thereof.
Consider this example (which uses type Rec from the previous example):
@@ -4908,43 +4916,6 @@
policy that controls this pragma is ``Post'Class``, not
``Post_Class``.
-Pragma Rename_Pragma
-============================
-.. index:: Pragmas, synonyms
-
-Syntax:
-
-
-::
-
- pragma Rename_Pragma (
- [New_Name =>] IDENTIFIER,
- [Renamed =>] pragma_IDENTIFIER);
-
-This pragma provides a mechanism for supplying new names for existing
-pragmas. The ``New_Name`` identifier can subsequently be used as a synonym for
-the Renamed pragma. For example, suppose you have code that was originally
-developed on a compiler that supports Inline_Only as an implementation defined
-pragma. And suppose the semantics of pragma Inline_Only are identical to (or at
-least very similar to) the GNAT implementation defined pragma
-Inline_Always. You could globally replace Inline_Only with Inline_Always.
-
-However, to avoid that source modification, you could instead add a
-configuration pragma:
-
-.. code-block:: ada
-
- pragma Rename_Pragma (
- New_Name => Inline_Only,
- Renamed => Inline_Always);
-
-
-Then GNAT will treat "pragma Inline_Only ..." as if you had written
-"pragma Inline_Always ...".
-
-Pragma Inline_Only will not necessarily mean the same thing as the other Ada
-compiler; it's up to you to make sure the semantics are close enough.
-
Pragma Pre
==========
.. index:: Pre
@@ -5729,6 +5700,43 @@
pertaining to remote access to class-wide types. At instantiation, the
actual type must be a remote access to class-wide type.
+Pragma Rename_Pragma
+============================
+.. index:: Pragmas, synonyms
+
+Syntax:
+
+
+::
+
+ pragma Rename_Pragma (
+ [New_Name =>] IDENTIFIER,
+ [Renamed =>] pragma_IDENTIFIER);
+
+This pragma provides a mechanism for supplying new names for existing
+pragmas. The ``New_Name`` identifier can subsequently be used as a synonym for
+the Renamed pragma. For example, suppose you have code that was originally
+developed on a compiler that supports Inline_Only as an implementation defined
+pragma. And suppose the semantics of pragma Inline_Only are identical to (or at
+least very similar to) the GNAT implementation defined pragma
+Inline_Always. You could globally replace Inline_Only with Inline_Always.
+
+However, to avoid that source modification, you could instead add a
+configuration pragma:
+
+.. code-block:: ada
+
+ pragma Rename_Pragma (
+ New_Name => Inline_Only,
+ Renamed => Inline_Always);
+
+
+Then GNAT will treat "pragma Inline_Only ..." as if you had written
+"pragma Inline_Always ...".
+
+Pragma Inline_Only will not necessarily mean the same thing as the other Ada
+compiler; it's up to you to make sure the semantics are close enough.
+
Pragma Restricted_Run_Time
==========================
diff --git a/gcc/ada/doc/gnat_rm/security_hardening_features.rst b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
new file mode 100644
index 0000000..1c46e3a4
--- /dev/null
+++ b/gcc/ada/doc/gnat_rm/security_hardening_features.rst
@@ -0,0 +1,89 @@
+.. _Security_Hardening_Features:
+
+***************************
+Security Hardening Features
+***************************
+
+This chapter describes Ada extensions aimed at security hardening that
+are provided by GNAT.
+
+.. Register Scrubbing:
+
+Register Scrubbing
+==================
+
+GNAT can generate code to zero-out hardware registers before returning
+from a subprogram.
+
+It can be enabled with the *-fzero-call-used-regs* command line
+option, to affect all subprograms in a compilation, and with a
+:samp:`Machine_Attribute` pragma, to affect only specific subprograms.
+
+.. code-block:: ada
+
+ procedure Foo;
+ pragma Machine_Attribute (Foo, "zero_call_used_regs", "used");
+ -- Before returning, Foo scrubs only call-clobbered registers
+ -- that it uses itself.
+
+ function Bar return Integer;
+ pragma Machine_Attribute (Bar, "zero_call_used_regs", "all");
+ -- Before returning, Bar scrubs all call-clobbered registers.
+
+
+For usage and more details on the command line option, and on the
+``zero_call_used_regs`` attribute, see :title:`Using the GNU Compiler
+Collection (GCC)`.
+
+
+.. Stack Scrubbing:
+
+Stack Scrubbing
+===============
+
+GNAT can generate code to zero-out stack frames used by subprograms.
+
+It can be activated with the :samp:`Machine_Attribute` pragma, on
+specific subprograms and variables.
+
+.. code-block:: ada
+
+ function Foo returns Integer;
+ pragma Machine_Attribute (Foo, "strub");
+ -- Foo and its callers are modified so as to scrub the stack
+ -- space used by Foo after it returns.
+
+ procedure Bar;
+ pragma Machine_Attribute (Bar, "strub", "internal");
+ -- Bar is turned into a wrapper for its original body,
+ -- and they scrub the stack used by the original body.
+
+ Var : Integer;
+ pragma Machine_Attribute (Var, "strub");
+ -- Reading from Var in a subprogram enables stack scrubbing
+ -- of the stack space used by the subprogram.
+
+
+There are also *-fstrub* command line options to control default
+settings. For usage and more details on the command line option, and
+on the ``strub`` attribute, see :title:`Using the GNU Compiler
+Collection (GCC)`.
+
+Note that Ada secondary stacks are not scrubbed. The restriction
+``No_Secondary_Stack`` avoids their use, and thus their accidental
+preservation of data that should be scrubbed.
+
+Also note that the machine attribute is not integrated in the Ada type
+system. Though it may modify subprogram and variable interfaces, it
+is not fully reflected in Ada types, ``Access`` attributes, renaming
+and overriding. Every access type, renaming, and overriding and
+overridden dispatching operations that may refer to an entity with an
+attribute-modified interface must be annotated with the same
+interface-modifying attribute, or with an interface-compatible one.
+
+Even then, the pragma is currently only functional when applied to
+subprograms and scalar variables; other uses, such as directly on
+types and subtypes, may be silently ignored. Specifically, it is not
+currently recommended to rely on any effects this pragma might be
+expected to have when calling subprograms through access-to-subprogram
+variables.
diff --git a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
index 3e7dc051..cbd780b 100644
--- a/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
+++ b/gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst
@@ -870,6 +870,44 @@
associated with the unit. This counter is typically used to check for access
before elaboration and to control multiple elaboration attempts.
+No_Dynamic_Accessibility_Checks
+-------------------------------
+.. index:: No_Dynamic_Accessibility_Checks
+
+[GNAT] No dynamic accessibility checks are generated when this restriction is
+in effect. Instead, dangling references are prevented via more conservative
+compile-time checking. More specifically, existing compile-time checks are
+enforced but with more conservative assumptions about the accessibility levels
+of the relevant entities. These conservative assumptions eliminate the need for
+dynamic accessibility checks.
+
+These new rules for computing (at compile-time) the accessibility level of an
+anonymous access type T are as follows:
+
+*
+ If T is a function result type then, from the caller's perspective, its level
+ is that of the innermost master enclosing the function call. From the callee's
+ perspective, the level of parameters and local variables of the callee is
+ statically deeper than the level of T.
+
+ For any other accessibility level L such that the level of parameters and local
+ variables of the callee is statically deeper than L, the level of T (from the
+ callee's perspective) is also statically deeper than L.
+*
+ If T is the type of a formal parameter then, from the caller's perspective,
+ its level is at least as deep as that of the type of the corresponding actual
+ parameter (whatever that actual parameter might be). From the callee's
+ perspective, the level of parameters and local variables of the callee is
+ statically deeper than the level of T.
+*
+ If T is the type of a discriminant then its level is that of the discriminated
+ type.
+*
+ If T is the type of a stand-alone object then its level is the level of the
+ object.
+*
+ In all other cases, the level of T is as defined by the existing rules of Ada.
+
No_Dynamic_Sized_Objects
------------------------
.. index:: No_Dynamic_Sized_Objects
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 5a69967..67fd130 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
@@ -1497,9 +1497,10 @@
:switch:`-gnateA`
Check that the actual parameters of a subprogram call are not aliases of one
- another. To qualify as aliasing, the actuals must denote objects of a composite
- type, their memory locations must be identical or overlapping, and at least one
- of the corresponding formal parameters must be of mode OUT or IN OUT.
+ another. To qualify as aliasing, their memory locations must be identical or
+ overlapping, at least one of the corresponding formal parameters must be of
+ mode OUT or IN OUT, and at least one of the corresponding formal parameters
+ must have its parameter passing mechanism not specified.
.. code-block:: ada
diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
index c4f186e..24ef9d6 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -3680,8 +3680,9 @@
The ``gnatmem`` utility monitors dynamic allocation and
deallocation activity in a program, and displays information about
incorrect deallocations and possible sources of memory leaks.
- It is designed to work in association with a static runtime library
- only and in this context provides three types of information:
+ It is designed to work for fixed-position executables in association
+ with a static runtime library only and in this context provides three
+ types of information:
* General information concerning memory management, such as the total
number of allocations and deallocations, the amount of allocated
@@ -3711,15 +3712,16 @@
$ gnatmem [ switches ] [ DEPTH ] user_program
- The program must have been linked with the instrumented version of the
+ The user program must be linked with the instrumented version of the
allocation and deallocation routines. This is done by linking with the
:file:`libgmem.a` library. For correct symbolic backtrace information,
- the user program should be compiled with debugging options
- (see :ref:`Switches_for_gcc`). For example to build :file:`my_program`:
+ the user program should also both be compiled with debugging options
+ (see :ref:`Switches_for_gcc`) and be linked at a fixed position. For
+ example to build :file:`my_program` with ``gnatmake``:
::
- $ gnatmake -g my_program -largs -lgmem
+ $ gnatmake -g my_program -largs -lgmem -no-pie
As library :file:`libgmem.a` contains an alternate body for package
``System.Memory``, :file:`s-memory.adb` should not be compiled and linked
diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
index f152ce3..d030cd4 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
@@ -4294,10 +4294,13 @@
Standard Output. Has no effect otherwise.
:switch:`--count={N}`
- If specified, compute the symbolic traceback ``N`` times in a row.
- This option is mostly useful for measuring the performance of
- ``gnatsymbolize``, particularly in the case where the cache is
- being used.
+ Compute the symbolic traceback ``N`` times in a row. This option
+ is mostly useful for measuring the performance of ``gnatsymbolize``,
+ particularly in the case where the cache is being used.
+
+ :switch:`--load`
+ Interpret the first address as the load address of the executable.
+ This is needed for position-independent executables on Windows.
Requirements for Correct Operation
----------------------------------
@@ -4311,12 +4314,7 @@
This program provides a functionality similar to ``addr2line``.
It has fewer options to tailor its output, but has been designed
to require fewer of the DWARF sections to be present in the
- executable. In particular, the following sections can be
- stripped from the executable without impact to ``gnatsymbolize``'s
- functionality:
-
- * ``.debug_str``
- * ``.debug_ranges``
+ executable. In particular, it works for code compiled with ``-g1``.
.. only:: PRO or GPL
diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
index 13993b8..4f68d25 100644
--- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
+++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
@@ -217,7 +217,10 @@
(if geteuid = 0 then True else raise Program_Error with "must be root");
It gets the effective user id, and if it's not 0 (i.e. root), it raises
-Program_Error.
+Program_Error. Note that if you re running the code in a container, this may
+not be sufficient, as you may have sufficient priviledge on the container,
+but not on the host machine running the container, so check that you also
+have sufficient priviledge for running the container image.
.. index:: Linux
.. index:: GNU/Linux
diff --git a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
index 39b9ca1..4a3b84d 100644
--- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
+++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
@@ -1409,16 +1409,12 @@
Check_Float_Overflow
Check_Name
Check_Policy
- Compile_Time_Error
- Compile_Time_Warning
- Compiler_Unit
- Compiler_Unit_Warning
Component_Alignment
Convention_Identifier
Debug_Policy
- Detect_Blocking
Default_Scalar_Storage_Order
Default_Storage_Pool
+ Detect_Blocking
Disable_Atomic_Synchronization
Discard_Names
Elaboration_Checks
@@ -1437,7 +1433,6 @@
Locking_Policy
No_Component_Reordering
No_Heap_Finalization
- No_Run_Time
No_Strict_Aliasing
Normalize_Scalars
Optimize_Alignment
@@ -1449,17 +1444,12 @@
Priority_Specific_Dispatching
Profile
Profile_Warnings
- Propagate_Exceptions
Queuing_Policy
- Rational
- Ravenscar
Rename_Pragma
- Restricted_Run_Time
Restrictions
- Restrictions_Warnings
+ Restriction_Warnings
Reviewable
Short_Circuit_And_Or
- Short_Descriptors
Source_File_Name
Source_File_Name_Project
SPARK_Mode
@@ -1468,7 +1458,6 @@
Suppress_Exception_Locations
Task_Dispatching_Policy
Unevaluated_Use_Of_Old
- Universal_Data
Unsuppress
Use_VADS_Size
Validity_Checks
@@ -1514,7 +1503,7 @@
The exception is No_Elaboration_Code which always applies to the entire
object file from a compilation, i.e. to the body, spec, and all subunits.
This restriction can be specified in a configuration pragma file, or it
-can be on the body and/or the spec (in eithe case it applies to all the
+can be on the body and/or the spec (in either case it applies to all the
relevant units). It can appear on a subunit only if it has previously
appeared in the body of spec.
@@ -4526,8 +4515,8 @@
constants. Function macros (macros with arguments) are partially translated
as comments, to be completed manually if needed.
* some extensions (e.g. vector types) are not supported
-* pointers to pointers or complex structures are mapped to System.Address
-* identifiers with identical name (except casing) will generate compilation
+* pointers to pointers are mapped to System.Address
+* identifiers with identical name (except casing) may generate compilation
errors (e.g. ``shm_get`` vs ``SHM_GET``).
The code is generated using Ada 2012 syntax, which makes it easier to interface
@@ -4546,14 +4535,17 @@
.. code-block:: sh
- $ g++ -c -fdump-ada-spec -C /usr/include/time.h
+ $ gcc -c -fdump-ada-spec -C /usr/include/time.h
$ gcc -c *.ads
will generate, under GNU/Linux, the following files: :file:`time_h.ads`,
:file:`bits_time_h.ads`, :file:`stddef_h.ads`, :file:`bits_types_h.ads` which
correspond to the files :file:`/usr/include/time.h`,
-:file:`/usr/include/bits/time.h`, etc..., and will then compile these Ada specs
-in Ada 2005 mode.
+:file:`/usr/include/bits/time.h`, etc..., and then compile these Ada specs.
+That is to say, the name of the Ada specs is in keeping with the relative path
+under :file:`/usr/include/` of the header files. This behavior is specific to
+paths ending with :file:`/include/`; in all the other cases, the name of the
+Ada specs is derived from the simple name of the header files instead.
The :switch:`-C` switch tells ``gcc`` to extract comments from headers,
and will attempt to generate corresponding Ada comments.
@@ -4564,39 +4556,8 @@
You can optionally specify a parent unit, of which all generated units will
be children, using :switch:`-fada-spec-parent={unit}`.
-Note that we recommend when possible to use the *g++* driver to
-generate bindings, even for most C headers, since this will in general
-generate better Ada specs. For generating bindings for C++ headers, it is
-mandatory to use the *g++* command, or *gcc -x c++* which
-is equivalent in this case. If *g++* cannot work on your C headers
-because of incompatibilities between C and C++, then you can fallback to
-``gcc`` instead.
-
-For an example of better bindings generated from the C++ front-end,
-the name of the parameters (when available) are actually ignored by the C
-front-end. Consider the following C header:
-
-.. code-block:: c
-
- extern void foo (int variable);
-
-with the C front-end, ``variable`` is ignored, and the above is handled as:
-
-.. code-block:: c
-
- extern void foo (int);
-
-generating a generic:
-
-.. code-block:: ada
-
- procedure foo (param1 : int);
-
-with the C++ front-end, the name is available, and we generate:
-
-.. code-block:: ada
-
- procedure foo (variable : int);
+The simple ``gcc```-based command works only for C headers. For C++ headers
+you need to use either the ``g++`` command or the combination ``gcc -x c++```.
In some cases, the generated bindings will be more complete or more meaningful
when defining some macros, which you can do via the :switch:`-D` switch. This
@@ -4604,7 +4565,7 @@
.. code-block:: sh
- $ g++ -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h
+ $ gcc -c -fdump-ada-spec -DXLIB_ILLEGAL_ACCESS -C /usr/include/X11/Xlib.h
The above will generate more complete bindings than a straight call without
the :switch:`-DXLIB_ILLEGAL_ACCESS` switch.
@@ -4626,7 +4587,7 @@
.. code-block:: sh
- $ g++ -c -fdump-ada-spec readline1.h
+ $ gcc -c -fdump-ada-spec readline1.h
.. _Generating_bindings_for_C++_headers:
@@ -4851,7 +4812,7 @@
=================================
This section compares the GNAT model with the approaches taken in
-other environents, first the C/C++ model and then the mechanism that
+other environments, first the C/C++ model and then the mechanism that
has been used in other Ada systems, in particular those traditionally
used for Ada 83.
diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 15bd9e8..0274e6b 100644
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -364,7 +364,9 @@
function Known_Alignment (E : Entity_Id) return B is
begin
- return not Field_Is_Initial_Zero (E, F_Alignment);
+ -- For some reason, Empty is passed to this sometimes
+
+ return No (E) or else not Field_Is_Initial_Zero (E, F_Alignment);
end Known_Alignment;
procedure Reinit_Alignment (Id : E) is
@@ -414,8 +416,7 @@
if Use_New_Unknown_Rep then
return not Field_Is_Initial_Zero (E, F_Esize);
else
- return Esize (E) /= Uint_0
- and then Present (Esize (E));
+ return Present (Esize (E)) and then Esize (E) /= Uint_0;
end if;
end Known_Esize;
@@ -654,16 +655,21 @@
P := Parent (Id);
end if;
+ while Nkind (P) in N_Selected_Component | N_Expanded_Name
+ or else (Nkind (P) = N_Defining_Program_Unit_Name
+ and then Is_Child_Unit (Id))
loop
- if Nkind (P) in N_Selected_Component | N_Expanded_Name
- or else (Nkind (P) = N_Defining_Program_Unit_Name
- and then Is_Child_Unit (Id))
- then
- P := Parent (P);
- else
- return P;
- end if;
+ P := Parent (P);
end loop;
+
+ if Is_Itype (Id)
+ and then Nkind (P) not in
+ N_Full_Type_Declaration | N_Subtype_Declaration
+ then
+ P := Empty;
+ end if;
+
+ return P;
end Declaration_Node;
---------------------
@@ -702,7 +708,7 @@
-- Entry_Index_Type --
----------------------
- function Entry_Index_Type (Id : E) return N is
+ function Entry_Index_Type (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Entry_Family);
return Etype (Discrete_Subtype_Definition (Parent (Id)));
@@ -1424,26 +1430,19 @@
function Is_Dynamic_Scope (Id : E) return B is
begin
- return
- Ekind (Id) = E_Block
+ return Ekind (Id) in E_Block
+ -- Including an E_Block that came from an N_Expression_With_Actions
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure
+ | E_Return_Statement
+ | E_Subprogram_Body
+ | E_Task_Type
or else
- Ekind (Id) = E_Function
- or else
- Ekind (Id) = E_Procedure
- or else
- Ekind (Id) = E_Subprogram_Body
- or else
- Ekind (Id) = E_Task_Type
- or else
- (Ekind (Id) = E_Limited_Private_Type
- and then Present (Full_View (Id))
- and then Ekind (Full_View (Id)) = E_Task_Type)
- or else
- Ekind (Id) = E_Entry
- or else
- Ekind (Id) = E_Entry_Family
- or else
- Ekind (Id) = E_Return_Statement;
+ (Ekind (Id) = E_Limited_Private_Type
+ and then Present (Full_View (Id))
+ and then Ekind (Full_View (Id)) = E_Task_Type);
end Is_Dynamic_Scope;
--------------------
@@ -1746,7 +1745,7 @@
-- Link_Entities --
-------------------
- procedure Link_Entities (First : Entity_Id; Second : Node_Id) is
+ procedure Link_Entities (First, Second : Entity_Id) is
begin
if Present (Second) then
Set_Prev_Entity (Second, First); -- First <-- Second
@@ -1975,6 +1974,8 @@
function Next_Index (Id : Node_Id) return Node_Id is
begin
+ pragma Assert (Nkind (Id) in N_Is_Index);
+ pragma Assert (No (Next (Id)) or else Nkind (Next (Id)) in N_Is_Index);
return Next (Id);
end Next_Index;
diff --git a/gcc/ada/einfo-utils.ads b/gcc/ada/einfo-utils.ads
index 4eca35e..8046722 100644
--- a/gcc/ada/einfo-utils.ads
+++ b/gcc/ada/einfo-utils.ads
@@ -625,7 +625,7 @@
-- WARNING: There is a matching C declaration of this subprogram in fe.h
- procedure Link_Entities (First : Entity_Id; Second : Entity_Id);
+ procedure Link_Entities (First, Second : Entity_Id);
-- Link entities First and Second in one entity chain.
--
-- NOTE: No updates are done to the First_Entity and Last_Entity fields
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 39ddd66..0239a70 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -610,12 +610,23 @@
-- tables must be consulted to determine if there actually is an active
-- Suppress or Unsuppress pragma that applies to the entity.
--- Class_Wide_Clone
--- Defined on subprogram entities. Set if the subprogram has a class-wide
--- pre- or postcondition, and the expression contains calls to other
--- primitive funtions of the type. Used to implement properly the
--- semantics of inherited operations whose class-wide condition may
--- be different from that of the ancestor (See AI012-0195).
+-- Class_Postconditions
+-- Defined on subprogram entities. Set if the subprogram has class-wide
+-- postconditions. Denotes the (and-then) expression built by merging
+-- inherited class-wide postconditions with its own class-wide
+-- postconditions.
+
+-- Class_Preconditions
+-- Defined on subprogram entities. Set if the subprogram has class-wide
+-- preconditions. Denotes the (or-else) expression built by merging
+-- inherited class-wide preconditions with its own class-wide
+-- preconditions.
+
+-- Class_Preconditions_Subprogram
+-- Defined on subprogram entities. Set on subprogram helpers and also on
+-- the indirect-call wrapper internally built for subprograms that have
+-- class-wide preconditions. References the subprogram that has the
+-- class-wide preconditions.
-- Class_Wide_Type
-- Defined in all type entities. For a tagged type or subtype, returns
@@ -746,9 +757,9 @@
-- Corresponding_Record_Component
-- Defined in components of a derived untagged record type, including
--- discriminants. For a regular component or a girder discriminant,
+-- discriminants. For a regular component or a stored discriminant,
-- points to the corresponding component in the parent type. Set to
--- Empty for a non-girder discriminant. It is used by the back end to
+-- Empty for a non-stored discriminant. It is used by the back end to
-- ensure the layout of the derived type matches that of the parent
-- type when there is no representation clause on the derived type.
@@ -818,7 +829,9 @@
-- a private type, then we obtain the declaration node denoted by the
-- full type, i.e. the full type declaration node. Also note that for
-- subprograms, this returns the {function,procedure}_specification, not
--- the subprogram_declaration.
+-- the subprogram_declaration. If the parent of an Itype is a type or
+-- subtype declaration, we return the declaration node as for any other
+-- type. For other Itypes, we return Empty.
-- Default_Aspect_Component_Value [base type only]
-- Defined in array types. Holds the static value specified in a
@@ -1029,6 +1042,11 @@
-- associated with the tagged type. For an untagged record, contains
-- No_Elist.
+-- Dynamic_Call_Helper
+-- Defined on subprogram entities. Set if the subprogram has class-wide
+-- preconditions. Denotes the helper that evaluates at run time the
+-- class-wide preconditions performing dispatching calls.
+
-- DTC_Entity
-- Defined in function and procedure entities. Set to Empty unless
-- the subprogram is dispatching in which case it references the
@@ -2182,6 +2200,18 @@
-- "off" and indicates that all SPARK_Mode pragmas found within must
-- be ignored.
+-- Ignored_Class_Postconditions
+-- Defined on subprogram entities. Set if the subprogram has class-wide
+-- postconditions. Denotes the (and-then) expression built by merging
+-- inherited ignored class-wide postconditions with its own ignored
+-- class-wide postconditions.
+
+-- Ignored_Class_Preconditions
+-- Defined on subprogram entities. Set if the subprogram has class-wide
+-- preconditions. Denotes the (or-else) expression built by merging
+-- inherited ignored class-wide preconditions with its own ignored
+-- class-wide preconditions.
+
-- Implementation_Base_Type (synthesized)
-- Applies to all entities. For types, similar to Base_Type, but never
-- returns a private type when applied to a non-private type. Instead in
@@ -2216,6 +2246,12 @@
-- is relocated to the corresponding package body, which must have a
-- corresponding nonlimited with_clause.
+-- Indirect_Call_Wrapper
+-- Defined on subprogram entities. Set if the subprogram has class-wide
+-- preconditions. Denotes the internal wrapper that checks preconditions
+-- and invokes the subprogram body. Subp'Access points to the indirect
+-- call wrapper if available.
+
-- Initialization_Statements
-- Defined in constants and variables. For a composite object initialized
-- with an aggregate that has been converted to a sequence of
@@ -2393,6 +2429,11 @@
-- Is_Class_Wide_Type (synthesized)
-- Applies to all entities, true for class wide types and subtypes
+-- Is_Class_Wide_Wrapper
+-- Defined in subprogram entities. Indicates that it has been created as
+-- a wrapper in a generic/instance scenario involving a formal type and
+-- a generic primitive operation when the actual is a class-wide type.
+
-- Is_Compilation_Unit
-- Defined in all entities. Set if the entity is a package or subprogram
-- entity for a compilation unit other than a subunit (since we treat
@@ -2400,11 +2441,11 @@
-- parent, we do not consider them to be separate units for this flag).
-- Is_Completely_Hidden
--- Defined on discriminants. Only set on girder discriminants of
--- untagged types. When set, the entity is a girder discriminant of a
+-- Defined on discriminants. Only set on stored discriminants of
+-- untagged types. When set, the entity is a stored discriminant of a
-- derived untagged type which is not directly visible in the derived
-- type because the derived type or one of its ancestors have renamed the
--- discriminants in the root type. Note: there are girder discriminants
+-- discriminants in the root type. Note: there are stored discriminants
-- which are not Completely_Hidden (e.g. discriminants of a root type).
-- Is_Composite_Type (synthesized)
@@ -2507,6 +2548,11 @@
-- Applies to all entities. Set to indicate to the backend that this
-- entity is associated with a dispatch table.
+-- Is_Dispatch_Table_Wrapper
+-- Applies to all entities. Set on wrappers built when the subprogram has
+-- class-wide preconditions or class-wide postconditions affected by
+-- overriding (AI12-0195).
+
-- Is_Dispatching_Operation
-- Defined in all entities. Set for procedures, functions, generic
-- procedures, and generic functions if the corresponding operation
@@ -3652,7 +3698,7 @@
-- Next_Discriminant (synthesized)
-- Applies to discriminants returned by First/Next_Discriminant. Returns
--- the next language-defined (i.e. perhaps non-girder) discriminant by
+-- the next language-defined (i.e. perhaps non-stored) discriminant by
-- following the chain of declared entities as long as the kind of the
-- entity corresponds to a discriminant. Note that the discriminants
-- might be the only components of the record. Returns Empty if there
@@ -3842,8 +3888,8 @@
-- Rec_Ext.Comp -> Rec_Ext.Parent. ... .Parent.Comp
--
-- In base untagged types:
--- Always points to itself except for non-girder discriminants, where
--- it points to the girder discriminant it renames.
+-- Always points to itself except for non-stored discriminants, where
+-- it points to the stored discriminant it renames.
--
-- In subtypes (tagged and untagged):
-- Points to the component in the base type.
@@ -4401,6 +4447,11 @@
-- Default_Scalar_Storage_Order (High_Order_First) was active at the time
-- the record or array was declared and therefore applies to it.
+-- Static_Call_Helper
+-- Defined on subprogram entities. Set if the subprogram has class-wide
+-- preconditions. Denotes the helper that evaluates at runtime the
+-- class-wide preconditions performing static calls.
+
-- Static_Discrete_Predicate
-- Defined in discrete types/subtypes with static predicates (with the
-- two flags Has_Predicates and Has_Static_Predicate set). Set if the
@@ -4878,6 +4929,7 @@
-- Is_Discrim_SO_Function
-- Is_Discriminant_Check_Function
-- Is_Dispatch_Table_Entity
+ -- Is_Dispatch_Table_Wrapper
-- Is_Dispatching_Operation
-- Is_Entry_Formal
-- Is_Exported
@@ -5484,7 +5536,14 @@
-- Linker_Section_Pragma
-- Contract
-- Import_Pragma (non-generic case only)
- -- Class_Wide_Clone
+ -- Class_Postconditions
+ -- Class_Preconditions
+ -- Class_Preconditions_Subprogram
+ -- Dynamic_Call_Helper
+ -- Ignored_Class_Preconditions
+ -- Ignored_Class_Postconditions
+ -- Indirect_Call_Wrapper
+ -- Static_Call_Helper
-- Protected_Subprogram (non-generic case only)
-- SPARK_Pragma
-- Original_Protected_Subprogram
@@ -5508,6 +5567,7 @@
-- Ignore_SPARK_Mode_Pragmas
-- Is_Abstract_Subprogram (non-generic case only)
-- Is_Called (non-generic case only)
+ -- Is_Class_Wide_Wrapper
-- Is_Constructor
-- Is_CUDA_Kernel (non-generic case only)
-- Is_DIC_Procedure (non-generic case only)
@@ -5680,6 +5740,7 @@
-- Default_Expressions_Processed
-- Has_Nested_Subprogram
-- Ignore_SPARK_Mode_Pragmas
+ -- Is_Class_Wide_Wrapper
-- Is_Elaboration_Checks_OK_Id
-- Is_Elaboration_Warnings_OK_Id
-- Is_Intrinsic_Subprogram
@@ -5840,7 +5901,14 @@
-- Linker_Section_Pragma
-- Contract
-- Import_Pragma (non-generic case only)
- -- Class_Wide_Clone
+ -- Class_Postconditions
+ -- Class_Preconditions
+ -- Class_Preconditions_Subprogram
+ -- Dynamic_Call_Helper
+ -- Ignored_Class_Preconditions
+ -- Ignored_Class_Postconditions
+ -- Indirect_Call_Wrapper
+ -- Static_Call_Helper
-- Protected_Subprogram (non-generic case only)
-- SPARK_Pragma
-- Original_Protected_Subprogram
@@ -5863,6 +5931,7 @@
-- Is_Abstract_Subprogram (non-generic case only)
-- Is_Asynchronous
-- Is_Called (non-generic case only)
+ -- Is_Class_Wide_Wrapper
-- Is_Constructor
-- Is_CUDA_Kernel
-- Is_DIC_Procedure (non-generic case only)
diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads
index 366df62..819d1ad 100644
--- a/gcc/ada/err_vars.ads
+++ b/gcc/ada/err_vars.ads
@@ -105,12 +105,15 @@
-- of the following global variables to appropriate values before making a
-- call to one of the error message routines with a string containing the
-- insertion character to get the value inserted in an appropriate format.
+ --
+ -- Some of these are initialized below, because they are read before being
+ -- set by clients.
Error_Msg_Col : Column_Number;
-- Column for @ insertion character in message
Error_Msg_Uint_1 : Uint;
- Error_Msg_Uint_2 : Uint;
+ Error_Msg_Uint_2 : Uint := No_Uint;
-- Uint values for ^ insertion characters in message
-- WARNING: There is a matching C declaration of these variables in fe.h
@@ -119,21 +122,21 @@
-- Source location for # insertion character in message
Error_Msg_Name_1 : Name_Id;
- Error_Msg_Name_2 : Name_Id;
- Error_Msg_Name_3 : Name_Id;
+ Error_Msg_Name_2 : Name_Id := No_Name;
+ Error_Msg_Name_3 : Name_Id := No_Name;
-- Name_Id values for % insertion characters in message
Error_Msg_File_1 : File_Name_Type;
- Error_Msg_File_2 : File_Name_Type;
- Error_Msg_File_3 : File_Name_Type;
+ Error_Msg_File_2 : File_Name_Type := No_File;
+ Error_Msg_File_3 : File_Name_Type := No_File;
-- File_Name_Type values for { insertion characters in message
Error_Msg_Unit_1 : Unit_Name_Type;
- Error_Msg_Unit_2 : Unit_Name_Type;
+ Error_Msg_Unit_2 : Unit_Name_Type := No_Unit_Name;
-- Unit_Name_Type values for $ insertion characters in message
Error_Msg_Node_1 : Node_Id;
- Error_Msg_Node_2 : Node_Id;
+ Error_Msg_Node_2 : Node_Id := Empty;
-- Node_Id values for & insertion characters in message
Error_Msg_Warn : Boolean;
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 99c7f9a..05a8266 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -3602,15 +3602,9 @@
end if;
-- The following assignment ensures that a second ampersand insertion
- -- character will correspond to the Error_Msg_Node_2 parameter. We
- -- suppress possible validity checks in case operating in -gnatVa mode,
- -- and Error_Msg_Node_2 is not needed and has not been set.
+ -- character will correspond to the Error_Msg_Node_2 parameter.
- declare
- pragma Suppress (Range_Check);
- begin
- Error_Msg_Node_1 := Error_Msg_Node_2;
- end;
+ Error_Msg_Node_1 := Error_Msg_Node_2;
end Set_Msg_Insertion_Node;
--------------------------------------
@@ -3790,15 +3784,9 @@
end if;
-- The following assignment ensures that a second percent insertion
- -- character will correspond to the Error_Msg_Unit_2 parameter. We
- -- suppress possible validity checks in case operating in -gnatVa mode,
- -- and Error_Msg_Unit_2 is not needed and has not been set.
+ -- character will correspond to the Error_Msg_Unit_2 parameter.
- declare
- pragma Suppress (Range_Check);
- begin
- Error_Msg_Unit_1 := Error_Msg_Unit_2;
- end;
+ Error_Msg_Unit_1 := Error_Msg_Unit_2;
end Set_Msg_Insertion_Unit_Name;
------------------
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index a2cd3c3..9e67b92 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -1119,17 +1119,11 @@
end if;
-- The following assignments ensure that the second and third {
- -- insertion characters will correspond to the Error_Msg_File_2 and
- -- Error_Msg_File_3 values and We suppress possible validity checks in
- -- case operating in -gnatVa mode, and Error_Msg_File_2 or
- -- Error_Msg_File_3 is not needed and has not been set.
+ -- insertion characters will correspond to the Error_Msg_File_2
+ -- and Error_Msg_File_3 values.
- declare
- pragma Suppress (Range_Check);
- begin
- Error_Msg_File_1 := Error_Msg_File_2;
- Error_Msg_File_2 := Error_Msg_File_3;
- end;
+ Error_Msg_File_1 := Error_Msg_File_2;
+ Error_Msg_File_2 := Error_Msg_File_3;
end Set_Msg_Insertion_File_Name;
-----------------------------------
@@ -1299,16 +1293,10 @@
-- The following assignments ensure that the second and third percent
-- insertion characters will correspond to the Error_Msg_Name_2 and
- -- Error_Msg_Name_3 as required. We suppress possible validity checks in
- -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
- -- and has not been set.
+ -- Error_Msg_Name_3 as required.
- declare
- pragma Suppress (Range_Check);
- begin
- Error_Msg_Name_1 := Error_Msg_Name_2;
- Error_Msg_Name_2 := Error_Msg_Name_3;
- end;
+ Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg_Name_2 := Error_Msg_Name_3;
end Set_Msg_Insertion_Name;
------------------------------------
@@ -1334,16 +1322,10 @@
-- The following assignments ensure that the second and third % or %%
-- insertion characters will correspond to the Error_Msg_Name_2 and
- -- Error_Msg_Name_3 values and We suppress possible validity checks in
- -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
- -- Error_Msg_Name_3 is not needed and has not been set.
+ -- Error_Msg_Name_3 values.
- declare
- pragma Suppress (Range_Check);
- begin
- Error_Msg_Name_1 := Error_Msg_Name_2;
- Error_Msg_Name_2 := Error_Msg_Name_3;
- end;
+ Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg_Name_2 := Error_Msg_Name_3;
end Set_Msg_Insertion_Name_Literal;
-------------------------------------
@@ -1427,15 +1409,9 @@
end loop;
-- The following assignment ensures that a second caret insertion
- -- character will correspond to the Error_Msg_Uint_2 parameter. We
- -- suppress possible validity checks in case operating in -gnatVa mode,
- -- and Error_Msg_Uint_2 is not needed and has not been set.
+ -- character will correspond to the Error_Msg_Uint_2 parameter.
- declare
- pragma Suppress (Range_Check);
- begin
- Error_Msg_Uint_1 := Error_Msg_Uint_2;
- end;
+ Error_Msg_Uint_1 := Error_Msg_Uint_2;
end Set_Msg_Insertion_Uint;
-----------------
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 88303c9..71bad3c 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -124,7 +124,8 @@
-- constants that are done in place.
function Must_Slide
- (Obj_Type : Entity_Id;
+ (Aggr : Node_Id;
+ Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean;
-- A static array aggregate in an object declaration can in most cases be
-- expanded in place. The one exception is when the aggregate is given
@@ -1776,7 +1777,7 @@
if Nkind (Parent (N)) = N_Assignment_Statement
and then Is_Array_Type (Comp_Typ)
and then Present (Component_Associations (Expr_Q))
- and then Must_Slide (Comp_Typ, Etype (Expr_Q))
+ and then Must_Slide (N, Comp_Typ, Etype (Expr_Q))
then
Set_Expansion_Delayed (Expr_Q, False);
Set_Analyzed (Expr_Q, False);
@@ -5718,6 +5719,15 @@
-- built directly into the target of the assignment it must be free
-- of side effects. N is the LHS of an assignment.
+ procedure Two_Pass_Aggregate_Expansion (N : Node_Id);
+ -- If the aggregate consists only of iterated associations then the
+ -- aggregate is constructed in two steps:
+ -- a) Build an expression to compute the number of elements
+ -- generated by each iterator, and use the expression to allocate
+ -- the destination aggregate.
+ -- b) Generate the loops corresponding to each iterator to insert
+ -- the elements in their proper positions.
+
----------------------------
-- Build_Constrained_Type --
----------------------------
@@ -6334,6 +6344,197 @@
end if;
end Safe_Left_Hand_Side;
+ ----------------------------------
+ -- Two_Pass_Aggregate_Expansion --
+ ----------------------------------
+
+ procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Comp_Type : constant Entity_Id := Etype (N);
+ Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
+ Index_Type : constant Entity_Id := Etype (First_Index (Etype (N)));
+ Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N);
+ TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N);
+
+ Assoc : Node_Id := First (Component_Associations (N));
+ Incr : Node_Id;
+ Iter : Node_Id;
+ New_Comp : Node_Id;
+ One_Loop : Node_Id;
+
+ Size_Expr_Code : List_Id;
+ Insertion_Code : List_Id := New_List;
+
+ begin
+ Size_Expr_Code := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size_Id,
+ Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)));
+
+ -- First pass: execute the iterators to count the number of elements
+ -- that will be generated.
+
+ while Present (Assoc) loop
+ Iter := Iterator_Specification (Assoc);
+ Incr := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Size_Id, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+
+ One_Loop := Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => New_Copy_Tree (Iter)),
+ Statements => New_List (Incr));
+
+ Append (One_Loop, Size_Expr_Code);
+ Next (Assoc);
+ end loop;
+
+ Insert_Actions (N, Size_Expr_Code);
+
+ -- Build a constrained subtype with the calculated length
+ -- and declare the proper bounded aggregate object.
+ -- The index type is some discrete type, so the bounds of the
+ -- constructed array are computed as T'Val (T'Pos (ineger bound));
+
+ declare
+ Pos_Lo : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_First)));
+
+ Aggr_Lo : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (New_Copy_Tree (Pos_Lo)));
+
+ -- Hi = Index_type'Pos (Lo + Size -1).
+
+ Pos_Hi : constant Node_Id :=
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Pos_Lo),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => New_Occurrence_Of (Size_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+
+ -- Corresponding index value
+
+ Aggr_Hi : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (New_Copy_Tree (Pos_Hi)));
+
+ SubE : constant Entity_Id := Make_Temporary (Loc, 'T');
+ SubD : constant Node_Id :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => SubE,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Comp_Type), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint
+ (Loc,
+ Constraints =>
+ New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi)))));
+
+ -- Create a temporary array of the above subtype which
+ -- will be used to capture the aggregate assignments.
+
+ TmpD : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => TmpE,
+ Object_Definition => New_Occurrence_Of (SubE, Loc));
+ begin
+ Insert_Actions (N, New_List (SubD, TmpD));
+ end;
+
+ -- Second pass: use the iterators to generate the elements of the
+ -- aggregate. Insertion index starts at Index_Type'First. We
+ -- assume that the second evaluation of each iterator generates
+ -- the same number of elements as the first pass, and consider
+ -- that the execution is erroneous (even if the RM does not state
+ -- this explicitly) if the number of elements generated differs
+ -- between first and second pass.
+
+ Assoc := First (Component_Associations (N));
+
+ -- Initialize insertion position to first array component.
+
+ Insertion_Code := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Index_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Index_Type, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_First)));
+
+ while Present (Assoc) loop
+ Iter := Iterator_Specification (Assoc);
+ New_Comp := Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (TmpE, Loc),
+ Expressions =>
+ New_List (New_Occurrence_Of (Index_Id, Loc))),
+ Expression => New_Copy_Tree (Expression (Assoc)));
+
+ -- Advance index position for insertion.
+
+ Incr := Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Index_Id, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions =>
+ New_List (New_Occurrence_Of (Index_Id, Loc))));
+
+ -- Add guard to skip last increment when upper bound is reached.
+
+ Incr := Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Occurrence_Of (Index_Id, Loc),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Type, Loc),
+ Attribute_Name => Name_Last)),
+ Then_Statements => New_List (Incr));
+
+ One_Loop := Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Iterator_Specification => Copy_Separate_Tree (Iter)),
+ Statements => New_List (New_Comp, Incr));
+
+ Append (One_Loop, Insertion_Code);
+ Next (Assoc);
+ end loop;
+
+ Insert_Actions (N, Insertion_Code);
+
+ -- Depending on context this may not work for build-in-place
+ -- arrays ???
+
+ Rewrite (N, New_Occurrence_Of (TmpE, Loc));
+
+ end Two_Pass_Aggregate_Expansion;
+
-- Local variables
Tmp : Entity_Id;
@@ -6371,6 +6572,15 @@
then
return;
+ elsif Present (Component_Associations (N))
+ and then Nkind (First (Component_Associations (N))) =
+ N_Iterated_Component_Association
+ and then
+ Present (Iterator_Specification (First (Component_Associations (N))))
+ then
+ Two_Pass_Aggregate_Expansion (N);
+ return;
+
-- Do not attempt expansion if error already detected. We may reach this
-- point in spite of previous errors when compiling with -gnatq, to
-- force all possible errors (this is the usual ACATS mode).
@@ -6657,7 +6867,7 @@
and then Parent_Kind = N_Object_Declaration
and then Present (Expression (Parent_Node))
and then not
- Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
+ Must_Slide (N, Etype (Defining_Identifier (Parent_Node)), Typ)
and then not Is_Bit_Packed_Array (Typ)
then
In_Place_Assign_OK_For_Declaration := True;
@@ -7038,6 +7248,9 @@
-- or Element_Association with non-static bounds, build an expression
-- to be used as the allocated size of the container. This may be an
-- overestimate if a filter is present, but is a safe approximation.
+ -- If bounds are dynamic the aggregate is created in two passes, and
+ -- the first generates a loop for the sole purpose of computing the
+ -- number of elements that will be generated on the seocnd pass.
procedure Expand_Iterated_Component (Comp : Node_Id);
-- Handle iterated_component_association and iterated_Element
@@ -7185,7 +7398,11 @@
return Build_Siz_Exp (First (Discrete_Choices (Comp)));
elsif Nkind (Comp) = N_Iterated_Element_Association then
- return -1; -- ??? build expression for size of the domain
+ return -1;
+
+ -- ??? Need to create code for a loop and add to generated code,
+ -- as is done for array aggregates with iterated element
+ -- associations, instead of using Append operations.
else
return -1;
@@ -7217,7 +7434,7 @@
if Present (Iterator_Specification (Comp)) then
- -- Either an Iterator_Specification of a Loop_Parameter_
+ -- Either an Iterator_Specification or a Loop_Parameter_
-- Specification is present.
L_Iteration_Scheme :=
@@ -8046,7 +8263,7 @@
Discr : Entity_Id;
Decl : Node_Id;
Num_Disc : Nat := 0;
- Num_Gird : Nat := 0;
+ Num_Stor : Nat := 0;
-- Start of processing for Generate_Aggregate_For_Derived_Type
@@ -8082,13 +8299,13 @@
Discr := First_Stored_Discriminant (Base_Type (Typ));
while Present (Discr) loop
- Num_Gird := Num_Gird + 1;
+ Num_Stor := Num_Stor + 1;
Next_Stored_Discriminant (Discr);
end loop;
-- Case of more stored discriminants than new discriminants
- if Num_Gird > Num_Disc then
+ if Num_Stor > Num_Disc then
-- Create a proper subtype of the parent type, which is the
-- proper implementation type for the aggregate, and convert
@@ -9411,13 +9628,16 @@
----------------
function Must_Slide
- (Obj_Type : Entity_Id;
+ (Aggr : Node_Id;
+ Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean
is
begin
-- No sliding if the type of the object is not established yet, if it is
-- an unconstrained type whose actual subtype comes from the aggregate,
- -- or if the two types are identical.
+ -- or if the two types are identical. If the aggregate contains only
+ -- an Others_Clause it gets its type from the context and no sliding
+ -- is involved either.
if not Is_Array_Type (Obj_Type) then
return False;
@@ -9428,8 +9648,13 @@
elsif Typ = Obj_Type then
return False;
+ elsif Is_Others_Aggregate (Aggr) then
+ return False;
+
else
-- Sliding can only occur along the first dimension
+ -- If any the bounds of non-static sliding is required
+ -- to force potential range checks.
declare
Bounds1 : constant Range_Nodes :=
@@ -9443,7 +9668,8 @@
not Is_OK_Static_Expression (Bounds1.Last) or else
not Is_OK_Static_Expression (Bounds2.Last)
then
- return False;
+ return True;
+
else
return Expr_Value (Bounds1.First) /= Expr_Value (Bounds2.First)
or else
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index c962c2a..096671f 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -165,8 +165,7 @@
-- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
-- have already been converted to the floating-point type for which Pkg was
-- instantiated. The Nam argument is the relevant attribute processing
- -- routine to be called. This is the same as the attribute name, except in
- -- the Unaligned_Valid case.
+ -- routine to be called. This is the same as the attribute name.
procedure Expand_Fpt_Attribute_R (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
@@ -2216,6 +2215,20 @@
if Is_Access_Protected_Subprogram_Type (Btyp) then
Expand_Access_To_Protected_Op (N, Pref, Typ);
+ -- If prefix is a subprogram that has class-wide preconditions and
+ -- an indirect-call wrapper (ICW) of such subprogram is available
+ -- then replace the prefix by the ICW.
+
+ elsif Is_Access_Subprogram_Type (Btyp)
+ and then Is_Entity_Name (Pref)
+ and then Present (Class_Preconditions (Entity (Pref)))
+ and then Present (Indirect_Call_Wrapper (Entity (Pref)))
+ then
+ Rewrite (Pref,
+ New_Occurrence_Of
+ (Indirect_Call_Wrapper (Entity (Pref)), Loc));
+ Analyze_And_Resolve (N, Typ);
+
-- If prefix is a type name, this is a reference to the current
-- instance of the type, within its initialization procedure.
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 45d5baf..418306f 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -26,6 +26,7 @@
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
+with Contracts; use Contracts;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
@@ -5352,10 +5353,66 @@
-------------------------------
procedure Expand_Freeze_Record_Type (N : Node_Id) is
+
+ procedure Build_Class_Condition_Subprograms (Typ : Entity_Id);
+ -- Create internal subprograms of Typ primitives that have class-wide
+ -- preconditions or postconditions; they are invoked by the caller to
+ -- evaluate the conditions.
+
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
-- Create An Equality function for the untagged variant record Typ and
-- attach it to the TSS list.
+ procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id);
+ -- Register dispatch-table wrappers in the dispatch table of Typ
+
+ ---------------------------------------
+ -- Build_Class_Condition_Subprograms --
+ ---------------------------------------
+
+ procedure Build_Class_Condition_Subprograms (Typ : Entity_Id) is
+ Prim_List : constant Elist_Id := Primitive_Operations (Typ);
+ Prim_Elmt : Elmt_Id := First_Elmt (Prim_List);
+ Prim : Entity_Id;
+
+ begin
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- Primitive with class-wide preconditions
+
+ if Comes_From_Source (Prim)
+ and then Has_Significant_Contract (Prim)
+ and then
+ (Present (Class_Preconditions (Prim))
+ or else Present (Ignored_Class_Preconditions (Prim)))
+ then
+ if Expander_Active then
+ Make_Class_Precondition_Subps (Prim);
+ end if;
+
+ -- Wrapper of a primitive that has or inherits class-wide
+ -- preconditions.
+
+ elsif Is_Primitive_Wrapper (Prim)
+ and then
+ (Present (Nearest_Class_Condition_Subprogram
+ (Spec_Id => Prim,
+ Kind => Class_Precondition))
+ or else
+ Present (Nearest_Class_Condition_Subprogram
+ (Spec_Id => Prim,
+ Kind => Ignored_Class_Precondition)))
+ then
+ if Expander_Active then
+ Make_Class_Precondition_Subps (Prim);
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Build_Class_Condition_Subprograms;
+
-----------------------------------
-- Build_Variant_Record_Equality --
-----------------------------------
@@ -5417,6 +5474,27 @@
end if;
end Build_Variant_Record_Equality;
+ --------------------------------------
+ -- Register_Dispatch_Table_Wrappers --
+ --------------------------------------
+
+ procedure Register_Dispatch_Table_Wrappers (Typ : Entity_Id) is
+ Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Typ));
+ Subp : Entity_Id;
+
+ begin
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+
+ if Is_Dispatch_Table_Wrapper (Subp) then
+ Append_Freeze_Actions (Typ,
+ Register_Primitive (Sloc (Subp), Subp));
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end Register_Dispatch_Table_Wrappers;
+
-- Local variables
Typ : constant Node_Id := Entity (N);
@@ -5666,6 +5744,13 @@
if not Building_Static_DT (Typ) then
Append_Freeze_Actions (Typ, Make_DT (Typ));
+
+ -- Register dispatch table wrappers in the dispatch table.
+ -- It could not be done when these wrappers were built
+ -- because, at that stage, the dispatch table was not
+ -- available.
+
+ Register_Dispatch_Table_Wrappers (Typ);
end if;
end if;
@@ -5857,6 +5942,13 @@
end loop;
end;
end if;
+
+ -- Build internal subprograms of primitives with class-wide
+ -- pre/postconditions.
+
+ if Is_Tagged_Type (Typ) then
+ Build_Class_Condition_Subprograms (Typ);
+ end if;
end Expand_Freeze_Record_Type;
------------------------------------
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 497a52b..8dcfa85 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -4703,7 +4704,7 @@
else
Set_Procedure_To_Call (N,
- Find_Prim_Op (Etype (Pool), Name_Allocate));
+ Find_Storage_Op (Etype (Pool), Name_Allocate));
end if;
end if;
end if;
@@ -6253,6 +6254,46 @@
return;
end if;
+ -- For the sake of GNATcoverage, generate an intermediate temporary in
+ -- the case where the if-expression is a condition in an outer decision,
+ -- in order to make sure that no branch is shared between the decisions.
+
+ elsif Opt.Suppress_Control_Flow_Optimizations
+ and then Nkind (Original_Node (Parent (N))) in N_Case_Expression
+ | N_Case_Statement
+ | N_If_Expression
+ | N_If_Statement
+ | N_Goto_When_Statement
+ | N_Loop_Statement
+ | N_Return_When_Statement
+ | N_Short_Circuit
+ then
+ declare
+ Cnn : constant Entity_Id := Make_Temporary (Loc, 'C');
+ Acts : List_Id;
+
+ begin
+ -- Generate:
+ -- do
+ -- Cnn : constant Typ := N;
+ -- in Cnn end
+
+ Acts := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (N)));
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => New_Occurrence_Of (Cnn, Loc),
+ Actions => Acts));
+
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end;
+
-- If no actions then no expansion needed, gigi will handle it using the
-- same approach as a C conditional expression.
@@ -6870,7 +6911,6 @@
if Ada_Version >= Ada_2012
and then Is_Acc
and then Ekind (Ltyp) = E_Anonymous_Access_Type
- and then not No_Dynamic_Accessibility_Checks_Enabled (Lop)
then
declare
Expr_Entity : Entity_Id := Empty;
@@ -6887,11 +6927,26 @@
end if;
end if;
+ -- When restriction No_Dynamic_Accessibility_Checks is in
+ -- effect, expand the membership test to a static value
+ -- since we cannot rely on dynamic levels.
+
+ if No_Dynamic_Accessibility_Checks_Enabled (Lop) then
+ if Static_Accessibility_Level
+ (Lop, Object_Decl_Level)
+ > Type_Access_Level (Rtyp)
+ then
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ end if;
+ Analyze_And_Resolve (N, Restyp);
+
-- If a conversion of the anonymous access value to the
-- tested type would be illegal, then the result is False.
- if not Valid_Conversion
- (Lop, Rtyp, Lop, Report_Errs => False)
+ elsif not Valid_Conversion
+ (Lop, Rtyp, Lop, Report_Errs => False)
then
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
Analyze_And_Resolve (N, Restyp);
@@ -7047,11 +7102,123 @@
--------------------------------
procedure Expand_N_Indexed_Component (N : Node_Id) is
+
+ Wild_Reads_May_Have_Bad_Side_Effects : Boolean
+ renames Validity_Check_Subscripts;
+ -- This Boolean needs to be True if reading from a bad address can
+ -- have a bad side effect (e.g., a segmentation fault that is not
+ -- transformed into a Storage_Error exception, or interactions with
+ -- memory-mapped I/O) that needs to be prevented. This refers to the
+ -- act of reading itself, not to any damage that might be caused later
+ -- by making use of whatever value was read. We assume here that
+ -- Validity_Check_Subscripts meets this requirement, but introduce
+ -- this declaration in order to document this assumption.
+
+ function Is_Renamed_Variable_Name (N : Node_Id) return Boolean;
+ -- Returns True if the given name occurs as part of the renaming
+ -- of a variable. In this case, the indexing operation should be
+ -- treated as a write, rather than a read, with respect to validity
+ -- checking. This is because the renamed variable can later be
+ -- written to.
+
+ function Type_Requires_Subscript_Validity_Checks_For_Reads
+ (Typ : Entity_Id) return Boolean;
+ -- If Wild_Reads_May_Have_Bad_Side_Effects is False and we are indexing
+ -- into an array of characters in order to read an element, it is ok
+ -- if an invalid index value goes undetected. But if it is an array of
+ -- pointers or an array of tasks, the consequences of such a read are
+ -- potentially more severe and so we want to detect an invalid index
+ -- value. This function captures that distinction; this is intended to
+ -- be consistent with the "but does not by itself lead to erroneous
+ -- ... execution" rule of RM 13.9.1(11).
+
+ ------------------------------
+ -- Is_Renamed_Variable_Name --
+ ------------------------------
+
+ function Is_Renamed_Variable_Name (N : Node_Id) return Boolean is
+ Rover : Node_Id := N;
+ begin
+ if Is_Variable (N) then
+ loop
+ declare
+ Rover_Parent : constant Node_Id := Parent (Rover);
+ begin
+ case Nkind (Rover_Parent) is
+ when N_Object_Renaming_Declaration =>
+ return Rover = Name (Rover_Parent);
+
+ when N_Indexed_Component
+ | N_Slice
+ | N_Selected_Component
+ =>
+ exit when Rover /= Prefix (Rover_Parent);
+ Rover := Rover_Parent;
+
+ -- No need to check for qualified expressions or type
+ -- conversions here, mostly because of the Is_Variable
+ -- test. It is possible to have a view conversion for
+ -- which Is_Variable yields True and which occurs as
+ -- part of an object renaming, but only if the type is
+ -- tagged; in that case this function will not be called.
+
+ when others =>
+ exit;
+ end case;
+ end;
+ end loop;
+ end if;
+ return False;
+ end Is_Renamed_Variable_Name;
+
+ -------------------------------------------------------
+ -- Type_Requires_Subscript_Validity_Checks_For_Reads --
+ -------------------------------------------------------
+
+ function Type_Requires_Subscript_Validity_Checks_For_Reads
+ (Typ : Entity_Id) return Boolean
+ is
+ -- a shorter name for recursive calls
+ function Needs_Check (Typ : Entity_Id) return Boolean renames
+ Type_Requires_Subscript_Validity_Checks_For_Reads;
+ begin
+ if Is_Access_Type (Typ)
+ or else Is_Tagged_Type (Typ)
+ or else Is_Concurrent_Type (Typ)
+ or else (Is_Array_Type (Typ)
+ and then Needs_Check (Component_Type (Typ)))
+ or else (Is_Scalar_Type (Typ)
+ and then Has_Aspect (Typ, Aspect_Default_Value))
+ then
+ return True;
+ end if;
+
+ if Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
+ begin
+ while Present (Comp) loop
+ if Needs_Check (Etype (Comp)) then
+ return True;
+ end if;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Type_Requires_Subscript_Validity_Checks_For_Reads;
+
+ -- Local constants
+
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
+ -- Start of processing for Expand_N_Indexed_Component
+
begin
-- A special optimization, if we have an indexed component that is
-- selecting from a slice, then we can eliminate the slice, since, for
@@ -7101,11 +7268,67 @@
-- Generate index and validity checks
- Generate_Index_Checks (N);
+ declare
+ Dims_Checked : Dimension_Set (Dimensions =>
+ (if Is_Array_Type (T)
+ then Number_Dimensions (T)
+ else 1));
+ -- Dims_Checked is used to avoid generating two checks (one in
+ -- Generate_Index_Checks, one in Apply_Subscript_Validity_Checks)
+ -- for the same index value in cases where the index check eliminates
+ -- the need for the validity check. The Is_Array_Type test avoids
+ -- cascading errors.
- if Validity_Checks_On and then Validity_Check_Subscripts then
- Apply_Subscript_Validity_Checks (N);
- end if;
+ begin
+ Generate_Index_Checks (N, Checks_Generated => Dims_Checked);
+
+ if Validity_Checks_On
+ and then (Validity_Check_Subscripts
+ or else Wild_Reads_May_Have_Bad_Side_Effects
+ or else Type_Requires_Subscript_Validity_Checks_For_Reads
+ (Typ)
+ or else Is_Renamed_Variable_Name (N))
+ then
+ if Validity_Check_Subscripts then
+ -- If we index into an array with an uninitialized variable
+ -- and we generate an index check that passes at run time,
+ -- passing that check does not ensure that the variable is
+ -- valid (although it does in the common case where the
+ -- object's subtype matches the index subtype).
+ -- Consider an uninitialized variable with subtype 1 .. 10
+ -- used to index into an array with bounds 1 .. 20 when the
+ -- value of the uninitialized variable happens to be 15.
+ -- The index check will succeed but the variable is invalid.
+ -- If Validity_Check_Subscripts is True then we need to
+ -- ensure validity, so we adjust Dims_Checked accordingly.
+ Dims_Checked.Elements := (others => False);
+
+ elsif Is_Array_Type (T) then
+ -- We are only adding extra validity checks here to
+ -- deal with uninitialized variables (but this includes
+ -- assigning one uninitialized variable to another). Other
+ -- ways of producing invalid objects imply erroneousness, so
+ -- the compiler can do whatever it wants for those cases.
+ -- If an index type has the Default_Value aspect specified,
+ -- then we don't have to worry about the possibility of an
+ -- uninitialized variable, so no need for these extra
+ -- validity checks.
+
+ declare
+ Idx : Node_Id := First_Index (T);
+ begin
+ for No_Check_Needed of Dims_Checked.Elements loop
+ No_Check_Needed := No_Check_Needed
+ or else Has_Aspect (Etype (Idx), Aspect_Default_Value);
+ Next_Index (Idx);
+ end loop;
+ end;
+ end if;
+
+ Apply_Subscript_Validity_Checks
+ (N, No_Check_Needed => Dims_Checked);
+ end if;
+ end;
-- If selecting from an array with atomic components, and atomic sync
-- is not suppressed for this array type, set atomic sync flag.
@@ -8569,8 +8792,7 @@
-- f'Machine (expr) to eliminate surprise from extra precision.
if Is_Floating_Point_Type (Typl)
- and then Nkind (Original_Node (Lhs)) = N_Attribute_Reference
- and then Attribute_Name (Original_Node (Lhs)) = Name_Result
+ and then Is_Attribute_Result (Original_Node (Lhs))
then
-- Stick in the Typ'Machine call if not already there
@@ -11338,7 +11560,7 @@
then
Par := Parent (Par);
- -- Any other case is not what we are looking for
+ -- Any other case is not what we are looking for
else
return False;
@@ -11374,7 +11596,7 @@
-- Local variables
- Pref : constant Node_Id := Prefix (N);
+ Pref : constant Node_Id := Prefix (N);
-- Start of processing for Expand_N_Slice
@@ -11400,7 +11622,7 @@
-- situation correctly in the assignment statement expansion).
-- 2. Prefix of indexed component (the slide is optimized away in this
- -- case, see the start of Expand_N_Slice.)
+ -- case, see the start of Expand_N_Indexed_Component.)
-- 3. Object renaming declaration, since we want the name of the
-- slice, not the value.
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 9827326..21ac2a2 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -31,7 +31,6 @@
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
-with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
@@ -3365,6 +3364,30 @@
renames Pattern_Match;
-- convenient rename for recursive calls
+ function Indexed_Element (Idx : Pos) return Node_Id;
+ -- Returns the Nth (well, ok, the Idxth) element of Object
+
+ ---------------------
+ -- Indexed_Element --
+ ---------------------
+
+ function Indexed_Element (Idx : Pos) return Node_Id is
+ Obj_Index : constant Node_Id :=
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Copy_Tree (Object)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Idx - 1));
+ begin
+ return Make_Indexed_Component (Loc,
+ Prefix => New_Copy_Tree (Object),
+ Expressions => New_List (Obj_Index));
+ end Indexed_Element;
+
+ -- Start of processing for Pattern_Match
+
begin
if Choice_Index /= 0 and not Suppress_Choice_Index_Update then
pragma Assert (Present (Choice_Index_Decl));
@@ -3399,16 +3422,51 @@
case Nkind (Pattern) is
when N_Aggregate =>
- return Result : Node_Id :=
- New_Occurrence_Of (Standard_True, Loc)
- do
+ declare
+ Result : Node_Id;
+ begin
if Is_Array_Type (Etype (Pattern)) then
- -- Calling Error_Msg_N during expansion is usually a
- -- mistake but is ok for an "unimplemented" message.
- Error_Msg_N
- ("array-valued case choices unimplemented",
- Pattern);
- return;
+
+ -- Nonpositional aggregates currently unimplemented.
+ -- We flag that case during analysis, so an assertion
+ -- is ok here.
+ --
+ pragma Assert
+ (not Is_Non_Empty_List
+ (Component_Associations (Pattern)));
+
+ declare
+ Agg_Length : constant Node_Id :=
+ Make_Integer_Literal (Loc,
+ List_Length (Expressions (Pattern)));
+
+ Obj_Length : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Copy_Tree (Object));
+ begin
+ Result := Make_Op_Eq (Loc,
+ Left_Opnd => Obj_Length,
+ Right_Opnd => Agg_Length);
+ end;
+
+ declare
+ Expr : Node_Id := First (Expressions (Pattern));
+ Idx : Pos := 1;
+ begin
+ while Present (Expr) loop
+ Result :=
+ Make_And_Then (Loc,
+ Left_Opnd => Result,
+ Right_Opnd =>
+ PM (Pattern => Expr,
+ Object => Indexed_Element (Idx)));
+ Next (Expr);
+ Idx := Idx + 1;
+ end loop;
+ end;
+
+ return Result;
end if;
-- positional notation should have been normalized
@@ -3425,6 +3483,8 @@
Selector_Name => New_Occurrence_Of
(Entity (Choice), Loc)));
begin
+ Result := New_Occurrence_Of (Standard_True, Loc);
+
while Present (Component_Assoc) loop
Choice := First (Choices (Component_Assoc));
while Present (Choice) loop
@@ -3530,27 +3590,82 @@
Next (Component_Assoc);
end loop;
end;
+ return Result;
+ end;
+
+ when N_String_Literal =>
+ return Result : Node_Id do
+ declare
+ Char_Type : constant Entity_Id :=
+ Root_Type (Component_Type (Etype (Pattern)));
+
+ -- If the component type is not a standard character
+ -- type then this string lit should have already been
+ -- transformed into an aggregate in
+ -- Resolve_String_Literal.
+ --
+ pragma Assert (Is_Standard_Character_Type (Char_Type));
+
+ Str : constant String_Id := Strval (Pattern);
+ Strlen : constant Nat := String_Length (Str);
+
+ Lit_Length : constant Node_Id :=
+ Make_Integer_Literal (Loc, Strlen);
+
+ Obj_Length : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Copy_Tree (Object));
+ begin
+ Result := Make_Op_Eq (Loc,
+ Left_Opnd => Obj_Length,
+ Right_Opnd => Lit_Length);
+
+ for Idx in 1 .. Strlen loop
+ declare
+ C : constant Char_Code :=
+ Get_String_Char (Str, Idx);
+ Obj_Element : constant Node_Id :=
+ Indexed_Element (Idx);
+ Char_Lit : Node_Id;
+ begin
+ Set_Character_Literal_Name (C);
+ Char_Lit :=
+ Make_Character_Literal (Loc,
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_CC (C));
+
+ Result :=
+ Make_And_Then (Loc,
+ Left_Opnd => Result,
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Obj_Element,
+ Right_Opnd => Char_Lit));
+ end;
+ end loop;
+ end;
end return;
when N_Qualified_Expression =>
- -- Make a copy for one of the two uses of Object; the choice
- -- of where to use the original and where to use the copy
- -- is arbitrary.
-
return Make_And_Then (Loc,
Left_Opnd => Make_In (Loc,
Left_Opnd => New_Copy_Tree (Object),
Right_Opnd => New_Copy_Tree (Subtype_Mark (Pattern))),
Right_Opnd =>
PM (Pattern => Expression (Pattern),
- Object => Object));
+ Object => New_Copy_Tree (Object)));
when N_Identifier | N_Expanded_Name =>
if Is_Type (Entity (Pattern)) then
return Make_In (Loc,
- Left_Opnd => Object,
+ Left_Opnd => New_Copy_Tree (Object),
Right_Opnd => New_Occurrence_Of
(Entity (Pattern), Loc));
+ elsif Ekind (Entity (Pattern)) = E_Constant then
+ return PM (Pattern =>
+ Expression (Parent (Entity (Pattern))),
+ Object => Object);
end if;
when N_Others_Choice =>
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 7717fa7..ce0bb80 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -73,8 +73,10 @@
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
@@ -4065,7 +4067,7 @@
end;
end if;
- -- If the formal is class wide and the actual is an aggregate, force
+ -- If the formal is class-wide and the actual is an aggregate, force
-- evaluation so that the back end who does not know about class-wide
-- type, does not generate a temporary of the wrong size.
@@ -4250,6 +4252,16 @@
Expand_Interface_Actuals (Call_Node);
end if;
+ -- Install class-wide preconditions runtime check when this is a
+ -- dispatching primitive that has or inherits class-wide preconditions;
+ -- otherwise no runtime check is installed.
+
+ if Nkind (Call_Node) in N_Subprogram_Call
+ and then Is_Dispatching_Operation (Subp)
+ then
+ Install_Class_Preconditions_Check (Call_Node);
+ end if;
+
-- Deals with Dispatch_Call if we still have a call, before expanding
-- extra actuals since this will be done on the re-analysis of the
-- dispatching call. Note that we do not try to shorten the actual list
@@ -4380,6 +4392,7 @@
-- the current subprogram is called.
if Is_Subprogram (Subp)
+ and then not Is_Ignored_Ghost_Entity (Subp)
and then Same_Or_Aliased_Subprograms (Subp, Current_Scope)
then
Check_Subprogram_Variant;
@@ -7855,18 +7868,6 @@
-- returned type may not be known yet (for private types).
Compute_Returns_By_Ref (Subp);
-
- -- When freezing a null procedure, analyze its delayed aspects now
- -- because we may not have reached the end of the declarative list when
- -- delayed aspects are normally analyzed. This ensures that dispatching
- -- calls are properly rewritten when the generated _Postcondition
- -- procedure is analyzed in the null procedure body.
-
- if Nkind (Parent (Subp)) = N_Procedure_Specification
- and then Null_Present (Parent (Subp))
- then
- Analyze_Entry_Or_Subprogram_Contract (Subp);
- end if;
end Freeze_Subprogram;
--------------------------
@@ -8101,6 +8102,367 @@
end if;
end Insert_Post_Call_Actions;
+ ---------------------------------------
+ -- Install_Class_Preconditions_Check --
+ ---------------------------------------
+
+ procedure Install_Class_Preconditions_Check (Call_Node : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Call_Node);
+
+ function Build_Dynamic_Check_Helper_Call return Node_Id;
+ -- Build call to the helper runtime function of the nearest ancestor
+ -- of the target subprogram that dynamically evaluates the merged
+ -- or-else preconditions.
+
+ function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id;
+ -- Build message associated with the class-wide precondition of Subp_Id
+ -- indicating the call that caused it.
+
+ function Build_Static_Check_Helper_Call return Node_Id;
+ -- Build call to the helper runtime function of the nearest ancestor
+ -- of the target subprogram that dynamically evaluates the merged
+ -- or-else preconditions.
+
+ function Class_Preconditions_Subprogram
+ (Spec_Id : Entity_Id;
+ Dynamic : Boolean) return Node_Id;
+ -- Return the nearest ancestor of Spec_Id defining a helper function
+ -- that evaluates a combined or-else expression containing all the
+ -- inherited class-wide preconditions; Dynamic enables searching for
+ -- the helper that dynamically evaluates preconditions using dispatching
+ -- calls; if False it searches for the helper that statically evaluates
+ -- preconditions; return Empty when not available (which means that no
+ -- preconditions check is required).
+
+ -------------------------------------
+ -- Build_Dynamic_Check_Helper_Call --
+ -------------------------------------
+
+ function Build_Dynamic_Check_Helper_Call return Node_Id is
+ Spec_Id : constant Entity_Id := Entity (Name (Call_Node));
+ CW_Subp : constant Entity_Id :=
+ Class_Preconditions_Subprogram (Spec_Id,
+ Dynamic => True);
+ Helper_Id : constant Entity_Id :=
+ Dynamic_Call_Helper (CW_Subp);
+ Actuals : constant List_Id := New_List;
+ A : Node_Id := First_Actual (Call_Node);
+ F : Entity_Id := First_Formal (Helper_Id);
+
+ begin
+ while Present (A) loop
+
+ -- Ensure that the evaluation of the actuals will not produce
+ -- side effects.
+
+ Remove_Side_Effects (A);
+
+ Append_To (Actuals, New_Copy_Tree (A));
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Helper_Id, Loc),
+ Parameter_Associations => Actuals);
+ end Build_Dynamic_Check_Helper_Call;
+
+ -------------------------
+ -- Build_Error_Message --
+ -------------------------
+
+ function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id is
+
+ procedure Append_Message
+ (Id : Entity_Id;
+ Is_First : in out Boolean);
+ -- Build the fragment of the message associated with subprogram Id;
+ -- Is_First facilitates identifying continuation messages.
+
+ --------------------
+ -- Append_Message --
+ --------------------
+
+ procedure Append_Message
+ (Id : Entity_Id;
+ Is_First : in out Boolean)
+ is
+ Prag : constant Node_Id := Get_Class_Wide_Pragma (Id,
+ Pragma_Precondition);
+ Msg : Node_Id;
+ Str_Id : String_Id;
+
+ begin
+ if No (Prag) or else Is_Ignored (Prag) then
+ return;
+ end if;
+
+ Msg := Expression (Last (Pragma_Argument_Associations (Prag)));
+ Str_Id := Strval (Msg);
+
+ if Is_First then
+ Is_First := False;
+
+ Append (Global_Name_Buffer, Strval (Msg));
+
+ if Id /= Subp_Id
+ and then Name_Buffer (1 .. 19) = "failed precondition"
+ then
+ Insert_Str_In_Name_Buffer ("inherited ", 8);
+ end if;
+
+ else
+ declare
+ Str : constant String := To_String (Str_Id);
+ From_Idx : Integer;
+
+ begin
+ Append (Global_Name_Buffer, ASCII.LF);
+ Append (Global_Name_Buffer, " or ");
+
+ From_Idx := Name_Len;
+ Append (Global_Name_Buffer, Str_Id);
+
+ if Str (1 .. 19) = "failed precondition" then
+ Insert_Str_In_Name_Buffer ("inherited ", From_Idx + 8);
+ end if;
+ end;
+ end if;
+ end Append_Message;
+
+ -- Local variables
+
+ Str_Loc : constant String := Build_Location_String (Loc);
+ Subps : constant Subprogram_List :=
+ Inherited_Subprograms (Subp_Id);
+ Is_First : Boolean := True;
+
+ -- Start of processing for Build_Error_Message
+
+ begin
+ Name_Len := 0;
+ Append_Message (Subp_Id, Is_First);
+
+ for Index in Subps'Range loop
+ Append_Message (Subps (Index), Is_First);
+ end loop;
+
+ if Present (Controlling_Argument (Call_Node)) then
+ Append (Global_Name_Buffer, " in dispatching call at ");
+ else
+ Append (Global_Name_Buffer, " in call at ");
+ end if;
+
+ Append (Global_Name_Buffer, Str_Loc);
+
+ return Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
+ end Build_Error_Message;
+
+ ------------------------------------
+ -- Build_Static_Check_Helper_Call --
+ ------------------------------------
+
+ function Build_Static_Check_Helper_Call return Node_Id is
+ Actuals : constant List_Id := New_List;
+ A : Node_Id;
+ Helper_Id : Entity_Id;
+ F : Entity_Id;
+ CW_Subp : Entity_Id;
+ Spec_Id : constant Entity_Id := Entity (Name (Call_Node));
+
+ begin
+ -- The target is the wrapper built to support inheriting body but
+ -- overriding pre/postconditions (AI12-0195).
+
+ if Is_Dispatch_Table_Wrapper (Spec_Id) then
+ CW_Subp := Spec_Id;
+
+ -- Common case
+
+ else
+ CW_Subp := Class_Preconditions_Subprogram (Spec_Id,
+ Dynamic => False);
+ end if;
+
+ Helper_Id := Static_Call_Helper (CW_Subp);
+
+ F := First_Formal (Helper_Id);
+ A := First_Actual (Call_Node);
+ while Present (A) loop
+
+ -- Ensure that the evaluation of the actuals will not produce
+ -- side effects.
+
+ Remove_Side_Effects (A);
+
+ if Is_Controlling_Actual (A)
+ and then Etype (F) /= Etype (A)
+ then
+ Append_To (Actuals,
+ Make_Unchecked_Type_Conversion (Loc,
+ New_Occurrence_Of (Etype (F), Loc),
+ New_Copy_Tree (A)));
+ else
+ Append_To (Actuals, New_Copy_Tree (A));
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Helper_Id, Loc),
+ Parameter_Associations => Actuals);
+ end Build_Static_Check_Helper_Call;
+
+ ------------------------------------
+ -- Class_Preconditions_Subprogram --
+ ------------------------------------
+
+ function Class_Preconditions_Subprogram
+ (Spec_Id : Entity_Id;
+ Dynamic : Boolean) return Node_Id
+ is
+ Subp_Id : constant Entity_Id := Ultimate_Alias (Spec_Id);
+
+ begin
+ -- Prevent cascaded errors
+
+ if not Is_Dispatching_Operation (Subp_Id) then
+ return Empty;
+
+ -- No need to search if this subprogram has the helper we are
+ -- searching
+
+ elsif Dynamic then
+ if Present (Dynamic_Call_Helper (Subp_Id)) then
+ return Subp_Id;
+ end if;
+ else
+ if Present (Static_Call_Helper (Subp_Id)) then
+ return Subp_Id;
+ end if;
+ end if;
+
+ -- Process inherited subprograms looking for class-wide
+ -- preconditions.
+
+ declare
+ Subps : constant Subprogram_List :=
+ Inherited_Subprograms (Subp_Id);
+ Subp_Id : Entity_Id;
+
+ begin
+ for Index in Subps'Range loop
+ Subp_Id := Subps (Index);
+
+ if Present (Alias (Subp_Id)) then
+ Subp_Id := Ultimate_Alias (Subp_Id);
+ end if;
+
+ -- Wrappers of class-wide pre/postconditions reference the
+ -- parent primitive that has the inherited contract.
+
+ if Is_Wrapper (Subp_Id)
+ and then Present (LSP_Subprogram (Subp_Id))
+ then
+ Subp_Id := LSP_Subprogram (Subp_Id);
+ end if;
+
+ if Dynamic then
+ if Present (Dynamic_Call_Helper (Subp_Id)) then
+ return Subp_Id;
+ end if;
+ else
+ if Present (Static_Call_Helper (Subp_Id)) then
+ return Subp_Id;
+ end if;
+ end if;
+ end loop;
+ end;
+
+ return Empty;
+ end Class_Preconditions_Subprogram;
+
+ -- Local variables
+
+ Dynamic_Check : constant Boolean :=
+ Present (Controlling_Argument (Call_Node));
+ Class_Subp : Entity_Id;
+ Cond : Node_Id;
+ Subp : Entity_Id;
+
+ -- Start of processing for Install_Class_Preconditions_Check
+
+ begin
+ -- Do not expand the check if we are compiling under restriction
+ -- No_Dispatching_Calls; the semantic analyzer has previously
+ -- notified the violation of this restriction.
+
+ if Dynamic_Check
+ and then Restriction_Active (No_Dispatching_Calls)
+ then
+ return;
+
+ -- Class-wide precondition check not needed in interface thunks since
+ -- they are installed in the dispatching call that caused invoking the
+ -- thunk.
+
+ elsif Is_Thunk (Current_Scope) then
+ return;
+ end if;
+
+ Subp := Entity (Name (Call_Node));
+
+ -- No check needed for this subprogram call if no class-wide
+ -- preconditions apply (or if the unique available preconditions
+ -- are ignored preconditions).
+
+ Class_Subp := Class_Preconditions_Subprogram (Subp, Dynamic_Check);
+
+ if No (Class_Subp)
+ or else No (Class_Preconditions (Class_Subp))
+ then
+ return;
+ end if;
+
+ -- Build and install the check
+
+ if Dynamic_Check then
+ Cond := Build_Dynamic_Check_Helper_Call;
+ else
+ Cond := Build_Static_Check_Helper_Call;
+ end if;
+
+ if Exception_Locations_Suppressed then
+ Insert_Action (Call_Node,
+ Make_If_Statement (Loc,
+ Condition => Make_Op_Not (Loc, Cond),
+ Then_Statements => New_List (
+ Make_Raise_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Assert_Failure), Loc)))));
+
+ -- Failed check with message indicating the failed precondition and the
+ -- call that caused it.
+
+ else
+ Insert_Action (Call_Node,
+ Make_If_Statement (Loc,
+ Condition => Make_Op_Not (Loc, Cond),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations =>
+ New_List (Build_Error_Message (Subp))))));
+ end if;
+ end Install_Class_Preconditions_Check;
+
-----------------------------------
-- Is_Build_In_Place_Result_Type --
-----------------------------------
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 76cec4d..196f7e6 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -121,6 +121,9 @@
-- The returned node is the root of the procedure body which will replace
-- the original function body, which is not needed for the C program.
+ procedure Install_Class_Preconditions_Check (Call_Node : Node_Id);
+ -- Install check of class-wide preconditions on the caller.
+
function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E is a BIP entity.
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 8d08ff1..71cad98 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -486,11 +486,11 @@
function Make_Deep_Proc
(Prim : Final_Primitives;
Typ : Entity_Id;
- Stmts : List_Id) return Node_Id;
+ Stmts : List_Id) return Entity_Id;
-- This function generates the tree for Deep_Initialize, Deep_Adjust or
- -- Deep_Finalize procedures according to the first parameter, these
- -- procedures operate on the type Typ. The Stmts parameter gives the body
- -- of the procedure.
+ -- Deep_Finalize procedures according to the first parameter. These
+ -- procedures operate on the type Typ. The Stmts parameter gives the
+ -- body of the procedure.
function Make_Deep_Array_Body
(Prim : Final_Primitives;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 427b430..694cf90 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -145,7 +145,7 @@
function Build_Corresponding_Record
(N : Node_Id;
- Ctyp : Node_Id;
+ Ctyp : Entity_Id;
Loc : Source_Ptr) return Node_Id;
-- Common to tasks and protected types. Copy discriminant specifications,
-- build record declaration. N is the type declaration, Ctyp is the
@@ -1583,9 +1583,9 @@
--------------------------------
function Build_Corresponding_Record
- (N : Node_Id;
- Ctyp : Entity_Id;
- Loc : Source_Ptr) return Node_Id
+ (N : Node_Id;
+ Ctyp : Entity_Id;
+ Loc : Source_Ptr) return Node_Id
is
Rec_Ent : constant Entity_Id :=
Make_Defining_Identifier
@@ -13796,14 +13796,15 @@
Comp : Node_Id;
Comp_Id : Entity_Id;
Decl_Id : Entity_Id;
+ Nam : Name_Id;
begin
Comp := First (Private_Declarations (Def));
while Present (Comp) loop
if Nkind (Comp) = N_Component_Declaration then
Comp_Id := Defining_Identifier (Comp);
- Decl_Id :=
- Make_Defining_Identifier (Loc, Chars (Comp_Id));
+ Nam := Chars (Comp_Id);
+ Decl_Id := Make_Defining_Identifier (Sloc (Comp_Id), Nam);
-- Minimal decoration
@@ -13818,6 +13819,14 @@
Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id));
Set_Is_Independent (Decl_Id, Is_Independent (Comp_Id));
+ -- Copy the Comes_From_Source flag of the component, as
+ -- the renaming may be the only entity directly seen by
+ -- the user in the context, but do not warn for it.
+
+ Set_Comes_From_Source
+ (Decl_Id, Comes_From_Source (Comp_Id));
+ Set_Warnings_Off (Decl_Id);
+
-- Generate:
-- comp_name : comp_typ renames _object.comp_name;
@@ -13828,10 +13837,8 @@
New_Occurrence_Of (Etype (Comp_Id), Loc),
Name =>
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Obj_Ent, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Comp_Id))));
+ Prefix => New_Occurrence_Of (Obj_Ent, Loc),
+ Selector_Name => Make_Identifier (Loc, Nam)));
Add (Decl);
end if;
@@ -14867,7 +14874,7 @@
Actuals : List_Id;
Formals : List_Id;
Decls : List_Id;
- Stmts : List_Id) return Node_Id
+ Stmts : List_Id) return Entity_Id
is
Actual : Entity_Id;
Expr : Node_Id := Empty;
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index a375169..96d78cc 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -409,7 +409,9 @@
when N_Expanded_Name
| N_Identifier
=>
- if not Present (Renamed_Object (Entity (Ren))) then
+ if No (Entity (Ren))
+ or else not Present (Renamed_Object (Entity (Ren)))
+ then
exit;
end if;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index bac6492..6ade54b 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -63,7 +63,6 @@
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
-with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
@@ -348,7 +347,7 @@
-- Build_Static_Dispatch_Tables --
----------------------------------
- procedure Build_Static_Dispatch_Tables (N : Entity_Id) is
+ procedure Build_Static_Dispatch_Tables (N : Node_Id) is
Target_List : List_Id;
procedure Build_Dispatch_Tables (List : List_Id);
@@ -697,233 +696,11 @@
Eq_Prim_Op : Entity_Id := Empty;
Controlling_Tag : Node_Id;
- procedure Build_Class_Wide_Check (E : Entity_Id);
- -- If the denoted subprogram has a class-wide precondition, generate a
- -- check using that precondition before the dispatching call, because
- -- this is the only class-wide precondition that applies to the call;
- -- otherwise climb to the ancestors searching for the enclosing
- -- overridden primitive of E that has a class-wide precondition (and
- -- use it to generate the check).
-
function New_Value (From : Node_Id) return Node_Id;
-- From is the original Expression. New_Value is equivalent to a call
-- to Duplicate_Subexpr with an explicit dereference when From is an
-- access parameter.
- ----------------------------
- -- Build_Class_Wide_Check --
- ----------------------------
-
- procedure Build_Class_Wide_Check (E : Entity_Id) is
- Subp : Entity_Id := E;
-
- function Has_Class_Wide_Precondition
- (Subp : Entity_Id) return Boolean;
- -- Evaluates if the dispatching subprogram Subp has a class-wide
- -- precondition.
-
- function Replace_Formals (N : Node_Id) return Traverse_Result;
- -- Replace occurrences of the formals of the subprogram by the
- -- corresponding actuals in the call, given that this check is
- -- performed outside of the body of the subprogram.
-
- -- If the dispatching call appears in the same scope as the
- -- declaration of the dispatching subprogram (for example in
- -- the expression of a local expression function), the spec
- -- has not been analyzed yet, in which case we use the Chars
- -- field to recognize intended occurrences of the formals.
-
- ---------------------------------
- -- Has_Class_Wide_Precondition --
- ---------------------------------
-
- function Has_Class_Wide_Precondition
- (Subp : Entity_Id) return Boolean
- is
- Prec : Node_Id := Empty;
-
- begin
- if Present (Contract (Subp))
- and then Present (Pre_Post_Conditions (Contract (Subp)))
- then
- Prec := Pre_Post_Conditions (Contract (Subp));
-
- while Present (Prec) loop
- exit when Pragma_Name (Prec) = Name_Precondition
- and then Class_Present (Prec);
- Prec := Next_Pragma (Prec);
- end loop;
- end if;
-
- return Present (Prec)
- and then not Is_Ignored (Prec);
- end Has_Class_Wide_Precondition;
-
- ---------------------
- -- Replace_Formals --
- ---------------------
-
- function Replace_Formals (N : Node_Id) return Traverse_Result is
- A : Node_Id;
- F : Entity_Id;
- begin
- if Is_Entity_Name (N) then
- F := First_Formal (Subp);
- A := First_Actual (Call_Node);
-
- if Present (Entity (N)) and then Is_Formal (Entity (N)) then
- while Present (F) loop
- if F = Entity (N) then
- if not Is_Controlling_Actual (N) then
- Rewrite (N, New_Copy_Tree (A));
-
- -- If the formal is class-wide, and thus not a
- -- controlling argument, preserve its type because
- -- it may appear in a nested call with a class-wide
- -- parameter.
-
- if Is_Class_Wide_Type (Etype (F)) then
- Set_Etype (N, Etype (F));
-
- -- Conversely, if this is a controlling argument
- -- (in a dispatching call in the condition) that
- -- is a dereference, the source is an access-to-
- -- -class-wide type, so preserve the dispatching
- -- nature of the call in the rewritten condition.
-
- elsif Nkind (Parent (N)) = N_Explicit_Dereference
- and then Is_Controlling_Actual (Parent (N))
- then
- Set_Controlling_Argument (Parent (Parent (N)),
- Parent (N));
- end if;
-
- -- Ensure that the type of the controlling actual
- -- matches the type of the controlling formal of the
- -- parent primitive Subp defining the class-wide
- -- precondition.
-
- elsif Is_Class_Wide_Type (Etype (A)) then
- Rewrite (N,
- Convert_To
- (Class_Wide_Type (Etype (F)),
- New_Copy_Tree (A)));
-
- else
- Rewrite (N,
- Convert_To
- (Etype (F),
- New_Copy_Tree (A)));
- end if;
-
- exit;
- end if;
-
- Next_Formal (F);
- Next_Actual (A);
- end loop;
-
- -- If the node is not analyzed, recognize occurrences of a
- -- formal by name, as would be done when resolving the aspect
- -- expression in the context of the subprogram.
-
- elsif not Analyzed (N)
- and then Nkind (N) = N_Identifier
- and then No (Entity (N))
- then
- while Present (F) loop
- if Chars (N) = Chars (F) then
- Rewrite (N, New_Copy_Tree (A));
- return Skip;
- end if;
-
- Next_Formal (F);
- Next_Actual (A);
- end loop;
- end if;
- end if;
-
- return OK;
- end Replace_Formals;
-
- procedure Update is new Traverse_Proc (Replace_Formals);
-
- -- Local variables
-
- Str_Loc : constant String := Build_Location_String (Loc);
-
- A : Node_Id;
- Cond : Node_Id;
- Msg : Node_Id;
- Prec : Node_Id;
-
- -- Start of processing for Build_Class_Wide_Check
-
- begin
- -- Climb searching for the enclosing class-wide precondition
-
- while not Has_Class_Wide_Precondition (Subp)
- and then Present (Overridden_Operation (Subp))
- loop
- Subp := Overridden_Operation (Subp);
- end loop;
-
- -- Locate class-wide precondition, if any
-
- if Present (Contract (Subp))
- and then Present (Pre_Post_Conditions (Contract (Subp)))
- then
- Prec := Pre_Post_Conditions (Contract (Subp));
-
- while Present (Prec) loop
- exit when Pragma_Name (Prec) = Name_Precondition
- and then Class_Present (Prec);
- Prec := Next_Pragma (Prec);
- end loop;
-
- if No (Prec) or else Is_Ignored (Prec) then
- return;
- end if;
-
- -- Ensure that the evaluation of the actuals will not produce side
- -- effects (since the check will use a copy of the actuals).
-
- A := First_Actual (Call_Node);
- while Present (A) loop
- Remove_Side_Effects (A);
- Next_Actual (A);
- end loop;
-
- -- The expression for the precondition is analyzed within the
- -- generated pragma. The message text is the last parameter of
- -- the generated pragma, indicating source of precondition.
-
- Cond :=
- New_Copy_Tree
- (Expression (First (Pragma_Argument_Associations (Prec))));
- Update (Cond);
-
- -- Build message indicating the failed precondition and the
- -- dispatching call that caused it.
-
- Msg := Expression (Last (Pragma_Argument_Associations (Prec)));
- Name_Len := 0;
- Append (Global_Name_Buffer, Strval (Msg));
- Append (Global_Name_Buffer, " in dispatching call at ");
- Append (Global_Name_Buffer, Str_Loc);
- Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
-
- Insert_Action (Call_Node,
- Make_If_Statement (Loc,
- Condition => Make_Op_Not (Loc, Cond),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (Msg)))));
- end if;
- end Build_Class_Wide_Check;
-
---------------
-- New_Value --
---------------
@@ -984,8 +761,6 @@
Subp := Alias (Subp);
end if;
- Build_Class_Wide_Check (Subp);
-
-- Definition of the class-wide type and the tagged type
-- If the controlling argument is itself a tag rather than a tagged
@@ -1016,6 +791,10 @@
Typ := Find_Specific_Type (CW_Typ);
+ -- The tagged type of a dispatching call must be frozen at this stage
+
+ pragma Assert (Is_Frozen (Typ));
+
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
@@ -5924,6 +5703,11 @@
Set_Is_True_Constant (TSD, Building_Static_DT (Typ));
+ -- The debugging information for type Ada.Tags.Type_Specific_Data is
+ -- needed by the debugger in order to display values of tagged types.
+
+ Set_Needs_Debug_Info (TSD, Needs_Debug_Info (Typ));
+
-- Initialize or declare the dispatch table object
if not Has_DT (Typ) then
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 45de0fb..86cb702 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -1151,7 +1151,7 @@
else
Set_Procedure_To_Call
- (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate));
+ (Free_Nod, Find_Storage_Op (Etype (Pool), Name_Deallocate));
end if;
end if;
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 43ecdcd..27b4e7d 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -752,10 +752,10 @@
-- value of which is Init_Val if present or null if not.
function Build_Simple_Declaration_With_Default
- (Decl_Id : Entity_Id;
- Init_Val : Entity_Id;
- Typ : Entity_Id;
- Default_Val : Entity_Id) return Node_Id;
+ (Decl_Id : Entity_Id;
+ Init_Val : Node_Id;
+ Typ : Node_Id;
+ Default_Val : Node_Id) return Node_Id;
-- Build a declaration the Defining_Identifier of which is Decl_Id, the
-- Object_Definition of which is Typ, the value of which is Init_Val if
-- present or Default otherwise.
@@ -983,7 +983,7 @@
function Build_Simple_Declaration_With_Default
(Decl_Id : Entity_Id;
Init_Val : Node_Id;
- Typ : Entity_Id;
+ Typ : Node_Id;
Default_Val : Node_Id) return Node_Id
is
Value : Node_Id := Init_Val;
@@ -1525,9 +1525,7 @@
begin
-- Attribute 'Old
- if Nkind (N) = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Old
- then
+ if Is_Attribute_Old (N) then
Pref := Prefix (N);
Indirect := Indirect_Temp_Needed (Etype (Pref));
@@ -2862,7 +2860,7 @@
procedure Expand_Pragma_Subprogram_Variant
(Prag : Node_Id;
- Subp_Id : Node_Id;
+ Subp_Id : Entity_Id;
Body_Decls : List_Id)
is
Curr_Decls : List_Id;
diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb
index 45db487..216065f5 100644
--- a/gcc/ada/exp_smem.adb
+++ b/gcc/ada/exp_smem.adb
@@ -86,7 +86,7 @@
function Build_Shared_Var_Proc_Call
(Loc : Source_Ptr;
- E : Node_Id;
+ E : Entity_Id;
N : Name_Id) return Node_Id;
-- Build a call to support procedure N for shared object E (provided by the
-- instance of System.Shared_Storage.Shared_Var_Procs associated to E).
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index ad5a6fa..cb18096 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1270,11 +1270,10 @@
---------------------------------
procedure Build_Class_Wide_Expression
- (Prag : Node_Id;
- Subp : Entity_Id;
- Par_Subp : Entity_Id;
- Adjust_Sloc : Boolean;
- Needs_Wrapper : out Boolean)
+ (Pragma_Or_Expr : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id;
+ Adjust_Sloc : Boolean)
is
function Replace_Entity (N : Node_Id) return Traverse_Result;
-- Replace reference to formal of inherited operation or to primitive
@@ -1294,7 +1293,7 @@
Adjust_Inherited_Pragma_Sloc (N);
end if;
- if Nkind (N) = N_Identifier
+ if Nkind (N) in N_Identifier | N_Operator_Symbol
and then Present (Entity (N))
and then
(Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
@@ -1319,84 +1318,6 @@
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
-
- -- AI12-0166: a precondition for a protected operation
- -- cannot include an internal call to a protected function
- -- of the type. In the case of an inherited condition for an
- -- overriding operation, both the operation and the function
- -- are given by primitive wrappers.
- -- Move this check to sem???
-
- if Ekind (New_E) = E_Function
- and then Is_Primitive_Wrapper (New_E)
- and then Is_Primitive_Wrapper (Subp)
- and then Scope (Subp) = Scope (New_E)
- and then Chars (Pragma_Identifier (Prag)) = Name_Precondition
- then
- Error_Msg_Node_2 := Wrapped_Entity (Subp);
- Error_Msg_NE
- ("internal call to& cannot appear in inherited "
- & "precondition of protected operation&",
- N, Wrapped_Entity (New_E));
- end if;
-
- -- If the entity is an overridden primitive and we are not
- -- in GNATprove mode, we must build a wrapper for the current
- -- inherited operation. If the reference is the prefix of an
- -- attribute such as 'Result (or others ???) there is no need
- -- for a wrapper: the condition is just rewritten in terms of
- -- the inherited subprogram.
-
- if Is_Subprogram (New_E)
- and then Nkind (Parent (N)) /= N_Attribute_Reference
- and then not GNATprove_Mode
- then
- Needs_Wrapper := True;
- end if;
- end if;
-
- -- Check that there are no calls left to abstract operations if
- -- the current subprogram is not abstract.
- -- Move this check to sem???
-
- if Nkind (Parent (N)) = N_Function_Call
- and then N = Name (Parent (N))
- then
- if not Is_Abstract_Subprogram (Subp)
- and then Is_Abstract_Subprogram (Entity (N))
- then
- Error_Msg_Sloc := Sloc (Current_Scope);
- Error_Msg_Node_2 := Subp;
- if Comes_From_Source (Subp) then
- Error_Msg_NE
- ("cannot call abstract subprogram & in inherited "
- & "condition for&#", Subp, Entity (N));
- else
- Error_Msg_NE
- ("cannot call abstract subprogram & in inherited "
- & "condition for inherited&#", Subp, Entity (N));
- end if;
-
- -- In SPARK mode, reject an inherited condition for an
- -- inherited operation if it contains a call to an overriding
- -- operation, because this implies that the pre/postconditions
- -- of the inherited operation have changed silently.
-
- elsif SPARK_Mode = On
- and then Warn_On_Suspicious_Contract
- and then Present (Alias (Subp))
- and then Present (New_E)
- and then Comes_From_Source (New_E)
- then
- Error_Msg_N
- ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
- Parent (Subp));
- Error_Msg_Sloc := Sloc (New_E);
- Error_Msg_Node_2 := Subp;
- Error_Msg_NE
- ("\overriding of&# forces overriding of&",
- Parent (Subp), New_E);
- end if;
end if;
-- Update type of function call node, which should be the same as
@@ -1422,26 +1343,17 @@
-- Local variables
- Par_Formal : Entity_Id;
- Subp_Formal : Entity_Id;
+ Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Subp);
+ Subp_Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
-- Start of processing for Build_Class_Wide_Expression
begin
- Needs_Wrapper := False;
+ pragma Assert (Par_Typ /= Subp_Typ);
- -- Add mapping from old formals to new formals
-
- Par_Formal := First_Formal (Par_Subp);
- Subp_Formal := First_Formal (Subp);
-
- while Present (Par_Formal) and then Present (Subp_Formal) loop
- Type_Map.Set (Par_Formal, Subp_Formal);
- Next_Formal (Par_Formal);
- Next_Formal (Subp_Formal);
- end loop;
-
- Replace_Condition_Entities (Prag);
+ Update_Primitives_Mapping (Par_Subp, Subp);
+ Map_Formals (Par_Subp, Subp);
+ Replace_Condition_Entities (Pragma_Or_Expr);
end Build_Class_Wide_Expression;
--------------------
@@ -1895,7 +1807,33 @@
Priv_Typ : Entity_Id;
-- The partial view of Par_Typ
+ Op_Node : Elmt_Id;
+ Par_Prim : Entity_Id;
+ Prim : Entity_Id;
+
begin
+ -- Map the overridden primitive to the overriding one; required by
+ -- Replace_References (called by Add_Inherited_DICs) to handle calls
+ -- to parent primitives.
+
+ Op_Node := First_Elmt (Primitive_Operations (T));
+ while Present (Op_Node) loop
+ Prim := Node (Op_Node);
+
+ if Present (Overridden_Operation (Prim))
+ and then Comes_From_Source (Prim)
+ then
+ Par_Prim := Overridden_Operation (Prim);
+
+ -- Create a mapping of the form:
+ -- parent type primitive -> derived type primitive
+
+ Type_Map.Set (Par_Prim, Prim);
+ end if;
+
+ Next_Elmt (Op_Node);
+ end loop;
+
-- Climb the parent type chain
Curr_Typ := T;
@@ -2097,14 +2035,11 @@
Stmts => Stmts);
end if;
- -- Otherwise the "full" DIC procedure verifies the DICs of the full
- -- view, well as DICs inherited from parent types. In addition, it
- -- indirectly verifies the DICs of the partial view by calling the
- -- "partial" DIC procedure.
+ -- Otherwise, the "full" DIC procedure verifies the DICs inherited from
+ -- parent types, as well as indirectly verifying the DICs of the partial
+ -- view by calling the "partial" DIC procedure.
else
- pragma Assert (Present (Full_Typ));
-
-- Check the DIC of the partial view by calling the "partial" DIC
-- procedure, unless the partial DIC body is empty. Generate:
@@ -2118,44 +2053,6 @@
New_Occurrence_Of (Obj_Id, Loc))));
end if;
- -- Derived subtypes do not have a partial view
-
- if Present (Priv_Typ) then
-
- -- The processing of the "full" DIC procedure intentionally
- -- skips the partial view because a) this may result in changes of
- -- visibility and b) lead to duplicate checks. However, when the
- -- full view is the underlying full view of an untagged derived
- -- type whose parent type is private, partial DICs appear on
- -- the rep item chain of the partial view only.
-
- -- package Pack_1 is
- -- type Root ... is private;
- -- private
- -- <full view of Root>
- -- end Pack_1;
-
- -- with Pack_1;
- -- package Pack_2 is
- -- type Child is new Pack_1.Root with Type_DIC => ...;
- -- <underlying full view of Child>
- -- end Pack_2;
-
- -- As a result, the processing of the full view must also consider
- -- all DICs of the partial view.
-
- if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
- null;
-
- -- Otherwise the DICs of the partial view are ignored
-
- else
- -- Ignore the DICs of the partial view by eliminating the view
-
- Priv_Typ := Empty;
- end if;
- end if;
-
-- Process inherited Default_Initial_Conditions for all parent types
Add_Parent_DICs (Work_Typ, Obj_Id, Stmts);
@@ -4914,7 +4811,7 @@
-- Convert_To_Actual_Subtype --
-------------------------------
- procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
+ procedure Convert_To_Actual_Subtype (Exp : Node_Id) is
Act_ST : Entity_Id;
begin
@@ -6359,6 +6256,32 @@
raise Program_Error;
end Find_Protection_Type;
+ function Find_Storage_Op
+ (Typ : Entity_Id;
+ Nam : Name_Id) return Entity_Id
+ is
+ use Sem_Util.Storage_Model_Support;
+
+ begin
+ if Has_Storage_Model_Type_Aspect (Typ) then
+ declare
+ SMT_Op : constant Entity_Id :=
+ Get_Storage_Model_Type_Entity (Typ, Nam);
+ begin
+ if not Present (SMT_Op) then
+ raise Program_Error;
+ else
+ return SMT_Op;
+ end if;
+ end;
+
+ -- Otherwise we assume that Typ is a descendant of Root_Storage_Pool
+
+ else
+ return Find_Prim_Op (Typ, Nam);
+ end if;
+ end Find_Storage_Op;
+
-----------------------
-- Find_Hook_Context --
-----------------------
@@ -7048,7 +6971,7 @@
-- Get_Index_Subtype --
-----------------------
- function Get_Index_Subtype (N : Node_Id) return Node_Id is
+ function Get_Index_Subtype (N : Node_Id) return Entity_Id is
P_Type : Entity_Id := Etype (Prefix (N));
Indx : Node_Id;
J : Int;
@@ -7073,6 +6996,15 @@
return Etype (Indx);
end Get_Index_Subtype;
+ -----------------------
+ -- Get_Mapped_Entity --
+ -----------------------
+
+ function Get_Mapped_Entity (E : Entity_Id) return Entity_Id is
+ begin
+ return Type_Map.Get (E);
+ end Get_Mapped_Entity;
+
---------------------
-- Get_Stream_Size --
---------------------
@@ -10350,6 +10282,36 @@
end if;
end Make_Variant_Comparison;
+ -----------------
+ -- Map_Formals --
+ -----------------
+
+ procedure Map_Formals
+ (Parent_Subp : Entity_Id;
+ Derived_Subp : Entity_Id;
+ Force_Update : Boolean := False)
+ is
+ Par_Formal : Entity_Id := First_Formal (Parent_Subp);
+ Subp_Formal : Entity_Id := First_Formal (Derived_Subp);
+
+ begin
+ if Force_Update then
+ Type_Map.Set (Parent_Subp, Derived_Subp);
+ end if;
+
+ -- At this stage either we are under regular processing and the caller
+ -- has previously ensured that these primitives are already mapped (by
+ -- means of calling previously to Update_Primitives_Mapping), or we are
+ -- processing a late-overriding primitive and Force_Update updated above
+ -- the mapping of these primitives.
+
+ while Present (Par_Formal) and then Present (Subp_Formal) loop
+ Type_Map.Set (Par_Formal, Subp_Formal);
+ Next_Formal (Par_Formal);
+ Next_Formal (Subp_Formal);
+ end loop;
+ end Map_Formals;
+
---------------
-- Map_Types --
---------------
@@ -10645,7 +10607,7 @@
end if;
-- Otherwise the constraint denotes a reference to some name
- -- which results in a Girder discriminant:
+ -- which results in a Stored discriminant:
-- vvvv
-- Name : ...;
@@ -10666,7 +10628,7 @@
return Find_Constraint_Value (Entity (Constr));
-- Otherwise the current constraint is an expression which yields
- -- a Girder discriminant:
+ -- a Stored discriminant:
-- type Typ (D1 : ...; DN : ...) is
-- new Anc (Discr => <expression>) with ...
@@ -10741,7 +10703,7 @@
-- that D_2 constrains D_1, therefore if the algorithm finds the
-- value of D_2, then this would also be the value for D_1.
- -- 2.2) The constraint is a name (aka Girder):
+ -- 2.2) The constraint is a name (aka Stored):
-- Name : ...
-- type Ancestor_1 (D_1 : ...) is tagged ...
@@ -10750,7 +10712,7 @@
-- In this case the name is the final value of D_1 because the
-- discriminant cannot be further constrained.
- -- 2.3) The constraint is an expression (aka Girder):
+ -- 2.3) The constraint is an expression (aka Stored):
-- type Ancestor_1 (D_1 : ...) is tagged ...
-- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
@@ -10861,7 +10823,7 @@
-- they relate to the primitives of the parent type. If there is a
-- meaningful relation, create a mapping of the form:
- -- parent type primitive -> perived type primitive
+ -- parent type primitive -> derived type primitive
if Present (Direct_Primitive_Operations (Deriv_Typ)) then
Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
@@ -11801,10 +11763,15 @@
-- case and it is better not to make an additional one for the attribute
-- itself, because the return type of many of them is universal integer,
-- which is a very large type for a temporary.
+ -- The prefix of an attribute reference Reduce may be syntactically an
+ -- aggregate, but will be expanded into a loop, so no need to remove
+ -- side-effects.
if Nkind (Exp) = N_Attribute_Reference
and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
+ and then (Attribute_Name (Exp) /= Name_Reduce
+ or else Nkind (Prefix (Exp)) /= N_Aggregate)
and then not Is_Name_Reference (Prefix (Exp))
then
Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
@@ -14123,10 +14090,12 @@
(Inher_Id : Entity_Id;
Subp_Id : Entity_Id)
is
+ Parent_Type : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
+ Derived_Type : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
+
begin
- Map_Types
- (Parent_Type => Find_Dispatching_Type (Inher_Id),
- Derived_Type => Find_Dispatching_Type (Subp_Id));
+ pragma Assert (Parent_Type /= Derived_Type);
+ Map_Types (Parent_Type, Derived_Type);
end Update_Primitives_Mapping;
----------------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 56ff61f..2b61132 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -270,28 +270,16 @@
-- not install a call to Abort_Defer.
procedure Build_Class_Wide_Expression
- (Prag : Node_Id;
- Subp : Entity_Id;
- Par_Subp : Entity_Id;
- Adjust_Sloc : Boolean;
- Needs_Wrapper : out Boolean);
- -- Build the expression for an inherited class-wide condition. Prag is
- -- the pragma constructed from the corresponding aspect of the parent
- -- subprogram, and Subp is the overriding operation, and Par_Subp is
- -- the overridden operation that has the condition. Adjust_Sloc is True
- -- when the sloc of nodes traversed should be adjusted for the inherited
- -- pragma. The routine is also called to check whether an inherited
- -- operation that is not overridden but has inherited conditions needs
- -- a wrapper, because the inherited condition includes calls to other
- -- primitives that have been overridden. In that case the first argument
- -- is the expression of the original class-wide aspect. In SPARK_Mode, such
- -- operation which are just inherited but have modified pre/postconditions
- -- are illegal.
- -- If there are calls to overridden operations in the condition, and the
- -- pragma applies to an inherited operation, a wrapper must be built for
- -- it to capture the new inherited condition. The flag Needs_Wrapper is
- -- set in that case so that the wrapper can be built, when the controlling
- -- type is frozen.
+ (Pragma_Or_Expr : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id;
+ Adjust_Sloc : Boolean);
+ -- Build the expression for an inherited class-wide condition. Pragma_Or_
+ -- _Expr is either the pragma constructed from the corresponding aspect of
+ -- the parent subprogram or the class-wide pre/postcondition built from the
+ -- parent, Subp is the overriding operation, and Par_Subp is the overridden
+ -- operation that has the condition. Adjust_Sloc is True when the sloc of
+ -- nodes traversed should be adjusted for the inherited pragma.
function Build_DIC_Call
(Loc : Source_Ptr;
@@ -612,7 +600,7 @@
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
-- Find the first primitive operation of a tagged type T with name Name.
-- This function allows the use of a primitive operation which is not
- -- directly visible. If T is a class wide type, then the reference is to an
+ -- directly visible. If T is a class-wide type, then the reference is to an
-- operation of the corresponding root type. It is an error if no primitive
-- operation with the given name is found.
@@ -640,6 +628,16 @@
-- Given a protected type or its corresponding record, find the type of
-- field _object.
+ function Find_Storage_Op
+ (Typ : Entity_Id;
+ Nam : Name_Id) return Entity_Id;
+ -- Given type Typ that's either a descendant of Root_Storage_Pool or else
+ -- specifies aspect Storage_Model_Type, returns the Entity_Id of the
+ -- subprogram associated with Nam, which must either be a primitive op of
+ -- the type in the case of a storage pool, or the operation corresponding
+ -- to Nam as specified in the aspect Storage_Model_Type. It is an error if
+ -- no operation corresponding to the given name is found.
+
function Find_Hook_Context (N : Node_Id) return Node_Id;
-- Determine a suitable node on which to attach actions related to N that
-- need to be elaborated unconditionally. In general this is the topmost
@@ -739,6 +737,10 @@
-- Used for First, Last, and Length, when the prefix is an array type.
-- Obtains the corresponding index subtype.
+ function Get_Mapped_Entity (E : Entity_Id) return Entity_Id;
+ -- Return the mapped entity of E; used to check inherited class-wide
+ -- pre/postconditions.
+
function Get_Stream_Size (E : Entity_Id) return Uint;
-- Return the stream size value of the subtype E
@@ -918,6 +920,15 @@
-- Subprogram_Variant. Generate a comparison between Curr_Val and Old_Val
-- depending on the variant mode (Increases / Decreases).
+ procedure Map_Formals
+ (Parent_Subp : Entity_Id;
+ Derived_Subp : Entity_Id;
+ Force_Update : Boolean := False);
+ -- Establish the mapping from the formals of Parent_Subp to the formals
+ -- of Derived_Subp; if Force_Update is True then mapping of Parent_Subp to
+ -- Derived_Subp is also updated; used to update mapping of late-overriding
+ -- primitives of a tagged type.
+
procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id);
-- Establish the following mapping between the attributes of tagged parent
-- type Parent_Type and tagged derived type Derived_Type.
@@ -1205,5 +1216,6 @@
private
pragma Inline (Duplicate_Subexpr);
pragma Inline (Force_Evaluation);
+ pragma Inline (Get_Mapped_Entity);
pragma Inline (Is_Library_Level_Tagged_Type);
end Exp_Util;
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 488e811..957f40b 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -61,10 +61,12 @@
#define Debug_Flag_Dot_KK debug__debug_flag_dot_kk
#define Debug_Flag_Dot_R debug__debug_flag_dot_r
+#define Debug_Flag_Dot_8 debug__debug_flag_dot_8
#define Debug_Flag_NN debug__debug_flag_nn
extern Boolean Debug_Flag_Dot_KK;
extern Boolean Debug_Flag_Dot_R;
+extern Boolean Debug_Flag_Dot_8;
extern Boolean Debug_Flag_NN;
/* einfo: */
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 15ce832..5f81d9e 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -35,6 +35,7 @@
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
@@ -56,6 +57,7 @@
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Prag; use Sem_Prag;
@@ -132,11 +134,6 @@
-- Attribute references to outer types are freeze points for those types;
-- this routine generates the required freeze nodes for them.
- procedure Check_Inherited_Conditions (R : Entity_Id);
- -- For a tagged derived type, create wrappers for inherited operations
- -- that have a class-wide condition, so it can be properly rewritten if
- -- it involves calls to other overriding primitives.
-
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
-- or tagged or contains something this is aliased or tagged, set
@@ -160,7 +157,7 @@
procedure Freeze_Enumeration_Type (Typ : Entity_Id);
-- Freeze enumeration type. The Esize field is set as processing
-- proceeds (i.e. set by default when the type is declared and then
- -- adjusted by rep clauses. What this procedure does is to make sure
+ -- adjusted by rep clauses). What this procedure does is to make sure
-- that if a foreign convention is specified, and no specific size
-- is given, then the size must be at least Integer'Size.
@@ -284,11 +281,11 @@
-- Full_View or Corresponding_Record_Type.
procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id);
- -- Expr is the expression for an address clause for entity Nam whose type
- -- is Typ. If Typ has a default initialization, and there is no explicit
- -- initialization in the source declaration, check whether the address
- -- clause might cause overlaying of an entity, and emit a warning on the
- -- side effect that the initialization will cause.
+ -- Expr is the expression for an address clause for the entity denoted by
+ -- Nam whose type is Typ. If Typ has a default initialization, and there is
+ -- no explicit initialization in the source declaration, check whether the
+ -- address clause might cause overlaying of an entity, and emit a warning
+ -- on the side effect that the initialization will cause.
-------------------------------
-- Adjust_Esize_For_Alignment --
@@ -636,13 +633,26 @@
Next (Param_Spec);
end loop;
- Body_Node :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call_Node)));
+ -- In GNATprove, prefer to generate an expression function whenever
+ -- possible, to benefit from the more precise analysis in that case
+ -- (as if an implicit postcondition had been generated).
+
+ if GNATprove_Mode
+ and then Nkind (Call_Node) = N_Simple_Return_Statement
+ then
+ Body_Node :=
+ Make_Expression_Function (Loc,
+ Specification => Spec,
+ Expression => Expression (Call_Node));
+ else
+ Body_Node :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call_Node)));
+ end if;
if Nkind (Decl) /= N_Subprogram_Declaration then
Rewrite (N,
@@ -1352,9 +1362,15 @@
elsif Is_Record_Type (Encl_Base)
and then not Comp_Byte_Aligned
then
- Error_Msg_N
- ("type of non-byte-aligned component must have same scalar "
- & "storage order as enclosing composite", Err_Node);
+ if Present (Component_Clause (Comp)) then
+ Error_Msg_N
+ ("type of non-byte-aligned component must have same scalar"
+ & " storage order as enclosing record", Err_Node);
+ else
+ Error_Msg_N
+ ("type of packed component must have same scalar"
+ & " storage order as enclosing record", Err_Node);
+ end if;
-- Warn if specified only for the outer composite
@@ -1464,90 +1480,322 @@
-- Check_Inherited_Conditions --
--------------------------------
- procedure Check_Inherited_Conditions (R : Entity_Id) is
- Prim_Ops : constant Elist_Id := Primitive_Operations (R);
- Decls : List_Id;
- Needs_Wrapper : Boolean;
- Op_Node : Elmt_Id;
- Par_Prim : Entity_Id;
- Prim : Entity_Id;
+ procedure Check_Inherited_Conditions
+ (R : Entity_Id;
+ Late_Overriding : Boolean := False)
+ is
+ Prim_Ops : constant Elist_Id := Primitive_Operations (R);
+ Decls : List_Id;
+ Op_Node : Elmt_Id;
+ Par_Prim : Entity_Id;
+ Prim : Entity_Id;
+ Wrapper_Needed : Boolean;
- procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id);
+ function Build_DTW_Body
+ (Loc : Source_Ptr;
+ DTW_Spec : Node_Id;
+ DTW_Decls : List_Id;
+ Par_Prim : Entity_Id;
+ Wrapped_Subp : Entity_Id) return Node_Id;
+ -- Build the body of the dispatch table wrapper containing the given
+ -- spec and declarations; the call to the wrapped subprogram includes
+ -- the proper type conversion.
+
+ function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id;
+ -- Build the spec of the dispatch table wrapper
+
+ procedure Build_Inherited_Condition_Pragmas
+ (Subp : Entity_Id;
+ Wrapper_Needed : out Boolean);
-- Build corresponding pragmas for an operation whose ancestor has
- -- class-wide pre/postconditions. If the operation is inherited, the
- -- pragmas force the creation of a wrapper for the inherited operation.
- -- If the ancestor is being overridden, the pragmas are constructed only
- -- to verify their legality, in case they contain calls to other
- -- primitives that may have been overridden.
+ -- class-wide pre/postconditions. If the operation is inherited then
+ -- Wrapper_Needed is returned True to force the creation of a wrapper
+ -- for the inherited operation. If the ancestor is being overridden,
+ -- the pragmas are constructed only to verify their legality, in case
+ -- they contain calls to other primitives that may have been overridden.
+
+ function Needs_Wrapper
+ (Class_Cond : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id) return Boolean;
+ -- Checks whether the dispatch-table wrapper (DTW) for Subp must be
+ -- built to evaluate the given class-wide condition.
+
+ --------------------
+ -- Build_DTW_Body --
+ --------------------
+
+ function Build_DTW_Body
+ (Loc : Source_Ptr;
+ DTW_Spec : Node_Id;
+ DTW_Decls : List_Id;
+ Par_Prim : Entity_Id;
+ Wrapped_Subp : Entity_Id) return Node_Id
+ is
+ Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Prim);
+ Actuals : constant List_Id := Empty_List;
+ Call : Node_Id;
+ Formal : Entity_Id := First_Formal (Par_Prim);
+ New_F_Spec : Entity_Id := First (Parameter_Specifications (DTW_Spec));
+ New_Formal : Entity_Id;
+
+ begin
+ -- Build parameter association for call to wrapped subprogram
+
+ while Present (Formal) loop
+ New_Formal := Defining_Identifier (New_F_Spec);
+
+ -- If the controlling argument is inherited, add conversion to
+ -- parent type for the call.
+
+ if Etype (Formal) = Par_Typ
+ and then Is_Controlling_Formal (Formal)
+ then
+ Append_To (Actuals,
+ Make_Type_Conversion (Loc,
+ New_Occurrence_Of (Par_Typ, Loc),
+ New_Occurrence_Of (New_Formal, Loc)));
+ else
+ Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
+ end if;
+
+ Next_Formal (Formal);
+ Next (New_F_Spec);
+ end loop;
+
+ if Ekind (Wrapped_Subp) = E_Procedure then
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Wrapped_Subp, Loc),
+ Parameter_Associations => Actuals);
+ else
+ Call :=
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Wrapped_Subp, Loc),
+ Parameter_Associations => Actuals));
+ end if;
+
+ return
+ Make_Subprogram_Body (Loc,
+ Specification => Copy_Subprogram_Spec (DTW_Spec),
+ Declarations => DTW_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call),
+ End_Label => Make_Identifier (Loc,
+ Chars (Defining_Entity (DTW_Spec)))));
+ end Build_DTW_Body;
+
+ --------------------
+ -- Build_DTW_Spec --
+ --------------------
+
+ function Build_DTW_Spec (Par_Prim : Entity_Id) return Node_Id is
+ DTW_Id : Entity_Id;
+ DTW_Spec : Node_Id;
+
+ begin
+ DTW_Spec := Build_Overriding_Spec (Par_Prim, R);
+ DTW_Id := Defining_Entity (DTW_Spec);
+
+ -- Add minimal decoration of fields
+
+ Mutate_Ekind (DTW_Id, Ekind (Par_Prim));
+ Set_LSP_Subprogram (DTW_Id, Par_Prim);
+ Set_Is_Dispatch_Table_Wrapper (DTW_Id);
+ Set_Is_Wrapper (DTW_Id);
+
+ -- The DTW wrapper is never a null procedure
+
+ if Nkind (DTW_Spec) = N_Procedure_Specification then
+ Set_Null_Present (DTW_Spec, False);
+ end if;
+
+ return DTW_Spec;
+ end Build_DTW_Spec;
---------------------------------------
-- Build_Inherited_Condition_Pragmas --
---------------------------------------
- procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id) is
- A_Post : Node_Id;
- A_Pre : Node_Id;
- New_Prag : Node_Id;
+ procedure Build_Inherited_Condition_Pragmas
+ (Subp : Entity_Id;
+ Wrapper_Needed : out Boolean)
+ is
+ Class_Pre : constant Node_Id :=
+ Class_Preconditions (Ultimate_Alias (Subp));
+ Class_Post : Node_Id := Class_Postconditions (Par_Prim);
+ A_Post : Node_Id;
+ New_Prag : Node_Id;
begin
- A_Pre := Get_Class_Wide_Pragma (Par_Prim, Pragma_Precondition);
+ Wrapper_Needed := False;
- if Present (A_Pre) then
- New_Prag := New_Copy_Tree (A_Pre);
- Build_Class_Wide_Expression
- (Prag => New_Prag,
- Subp => Prim,
- Par_Subp => Par_Prim,
- Adjust_Sloc => False,
- Needs_Wrapper => Needs_Wrapper);
-
- if Needs_Wrapper
- and then not Comes_From_Source (Subp)
- and then Expander_Active
- then
- Append (New_Prag, Decls);
- end if;
+ if No (Class_Pre) and then No (Class_Post) then
+ return;
end if;
- A_Post := Get_Class_Wide_Pragma (Par_Prim, Pragma_Postcondition);
+ -- For class-wide preconditions we just evaluate whether the wrapper
+ -- is needed; there is no need to build the pragma since the check
+ -- is performed on the caller side.
- if Present (A_Post) then
- New_Prag := New_Copy_Tree (A_Post);
+ if Present (Class_Pre)
+ and then Needs_Wrapper (Class_Pre, Subp, Par_Prim)
+ then
+ Wrapper_Needed := True;
+ end if;
+
+ -- For class-wide postconditions we evaluate whether the wrapper is
+ -- needed and we build the class-wide postcondition pragma to install
+ -- it in the wrapper.
+
+ if Present (Class_Post)
+ and then Needs_Wrapper (Class_Post, Subp, Par_Prim)
+ then
+ Wrapper_Needed := True;
+
+ -- Update the class-wide postcondition
+
+ Class_Post := New_Copy_Tree (Class_Post);
Build_Class_Wide_Expression
- (Prag => New_Prag,
- Subp => Prim,
+ (Pragma_Or_Expr => Class_Post,
+ Subp => Subp,
Par_Subp => Par_Prim,
- Adjust_Sloc => False,
- Needs_Wrapper => Needs_Wrapper);
+ Adjust_Sloc => False);
- if Needs_Wrapper
- and then not Comes_From_Source (Subp)
- and then Expander_Active
- then
- Append (New_Prag, Decls);
+ -- Install the updated class-wide postcondition in a copy of the
+ -- pragma postcondition defined for the nearest ancestor.
+
+ A_Post := Get_Class_Wide_Pragma (Par_Prim,
+ Pragma_Postcondition);
+
+ if No (A_Post) then
+ declare
+ Subps : constant Subprogram_List :=
+ Inherited_Subprograms (Subp);
+ begin
+ for Index in Subps'Range loop
+ A_Post := Get_Class_Wide_Pragma (Subps (Index),
+ Pragma_Postcondition);
+ exit when Present (A_Post);
+ end loop;
+ end;
end if;
+
+ New_Prag := New_Copy_Tree (A_Post);
+ Rewrite
+ (Expression (First (Pragma_Argument_Associations (New_Prag))),
+ Class_Post);
+ Append (New_Prag, Decls);
end if;
end Build_Inherited_Condition_Pragmas;
+ -------------------
+ -- Needs_Wrapper --
+ -------------------
+
+ function Needs_Wrapper
+ (Class_Cond : Node_Id;
+ Subp : Entity_Id;
+ Par_Subp : Entity_Id) return Boolean
+ is
+ Result : Boolean := False;
+
+ function Check_Entity (N : Node_Id) return Traverse_Result;
+ -- Check calls to overridden primitives
+
+ --------------------
+ -- Replace_Entity --
+ --------------------
+
+ function Check_Entity (N : Node_Id) return Traverse_Result is
+ New_E : Entity_Id;
+
+ begin
+ if Nkind (N) = N_Identifier
+ and then Present (Entity (N))
+ and then
+ (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
+ and then
+ (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else Attribute_Name (Parent (N)) /= Name_Class)
+ then
+ -- The check does not apply to dispatching calls within the
+ -- condition, but only to calls whose static tag is that of
+ -- the parent type.
+
+ if Is_Subprogram (Entity (N))
+ and then Nkind (Parent (N)) = N_Function_Call
+ and then Present (Controlling_Argument (Parent (N)))
+ then
+ return OK;
+ end if;
+
+ -- Determine whether entity has a renaming
+
+ New_E := Get_Mapped_Entity (Entity (N));
+
+ -- If the entity is an overridden primitive and we are not
+ -- in GNATprove mode, we must build a wrapper for the current
+ -- inherited operation. If the reference is the prefix of an
+ -- attribute such as 'Result (or others ???) there is no need
+ -- for a wrapper: the condition is just rewritten in terms of
+ -- the inherited subprogram.
+
+ if Present (New_E)
+ and then Comes_From_Source (New_E)
+ and then Is_Subprogram (New_E)
+ and then Nkind (Parent (N)) /= N_Attribute_Reference
+ and then not GNATprove_Mode
+ then
+ Result := True;
+ return Abandon;
+ end if;
+ end if;
+
+ return OK;
+ end Check_Entity;
+
+ procedure Check_Condition_Entities is
+ new Traverse_Proc (Check_Entity);
+
+ -- Start of processing for Needs_Wrapper
+
+ begin
+ Update_Primitives_Mapping (Par_Subp, Subp);
+
+ Map_Formals (Par_Subp, Subp);
+ Check_Condition_Entities (Class_Cond);
+
+ return Result;
+ end Needs_Wrapper;
+
-- Start of processing for Check_Inherited_Conditions
begin
- Op_Node := First_Elmt (Prim_Ops);
- while Present (Op_Node) loop
- Prim := Node (Op_Node);
+ if Late_Overriding then
+ Op_Node := First_Elmt (Prim_Ops);
+ while Present (Op_Node) loop
+ Prim := Node (Op_Node);
- -- Map the overridden primitive to the overriding one. This takes
- -- care of all overridings and is done only once.
+ -- Map the overridden primitive to the overriding one
- if Present (Overridden_Operation (Prim))
- and then Comes_From_Source (Prim)
- then
- Par_Prim := Overridden_Operation (Prim);
- Update_Primitives_Mapping (Par_Prim, Prim);
- end if;
+ if Present (Overridden_Operation (Prim))
+ and then Comes_From_Source (Prim)
+ then
+ Par_Prim := Overridden_Operation (Prim);
+ Update_Primitives_Mapping (Par_Prim, Prim);
- Next_Elmt (Op_Node);
- end loop;
+ -- Force discarding previous mappings of its formals
+
+ Map_Formals (Par_Prim, Prim, Force_Update => True);
+ end if;
+
+ Next_Elmt (Op_Node);
+ end loop;
+ end if;
-- Perform validity checks on the inherited conditions of overriding
-- operations, for conformance with LSP, and apply SPARK-specific
@@ -1583,12 +1831,6 @@
if GNATprove_Mode then
Collect_Inherited_Class_Wide_Conditions (Prim);
-
- -- Otherwise build the corresponding pragmas to check for legality
- -- of the inherited condition.
-
- else
- Build_Inherited_Condition_Pragmas (Prim);
end if;
end if;
@@ -1602,12 +1844,17 @@
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
- Decls := Empty_List;
- Prim := Node (Op_Node);
- Needs_Wrapper := False;
+ Decls := Empty_List;
+ Prim := Node (Op_Node);
+ Wrapper_Needed := False;
- if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
- Par_Prim := Alias (Prim);
+ -- Skip internal entities built for mapping interface primitives
+
+ if not Comes_From_Source (Prim)
+ and then Present (Alias (Prim))
+ and then No (Interface_Alias (Prim))
+ then
+ Par_Prim := Ultimate_Alias (Prim);
-- When the primitive is an LSP wrapper we climb to the parent
-- primitive that has the inherited contract.
@@ -1625,39 +1872,39 @@
-- in the loop above.
Analyze_Entry_Or_Subprogram_Contract (Par_Prim);
- Build_Inherited_Condition_Pragmas (Prim);
+ Build_Inherited_Condition_Pragmas (Prim, Wrapper_Needed);
end if;
- if Needs_Wrapper
+ if Wrapper_Needed
and then not Is_Abstract_Subprogram (Par_Prim)
and then Expander_Active
then
- -- We need to build a new primitive that overrides the inherited
- -- one, and whose inherited expression has been updated above.
- -- These expressions are the arguments of pragmas that are part
- -- of the declarations of the wrapper. The wrapper holds a single
- -- statement that is a call to the class-wide clone, where the
- -- controlling actuals are conversions to the corresponding type
- -- in the parent primitive:
-
- -- procedure New_Prim (F1 : T1; ...);
- -- procedure New_Prim (F1 : T1; ...) is
- -- pragma Check (Precondition, Expr);
- -- begin
- -- Par_Prim_Clone (Par_Type (F1), ...);
- -- end;
-
- -- If the primitive is a function the statement is a return
- -- statement with a call.
+ -- Build the dispatch-table wrapper (DTW). The support for
+ -- AI12-0195 relies on two kind of wrappers: one for indirect
+ -- calls (also used for AI12-0220), and one for putting in the
+ -- dispatch table:
+ --
+ -- 1) "indirect-call wrapper" (ICW) is needed anytime there are
+ -- class-wide preconditions. Prim'Access will point directly
+ -- at the ICW if any, or at the "pristine" body if Prim has
+ -- no class-wide preconditions.
+ --
+ -- 2) "dispatch-table wrapper" (DTW) is needed anytime the class
+ -- wide preconditions *or* the class-wide postconditions are
+ -- affected by overriding.
+ --
+ -- The DTW holds a single statement that is a single call where
+ -- the controlling actuals are conversions to the corresponding
+ -- type in the parent primitive. If the primitive is a function
+ -- the statement is a return statement with a call.
declare
Alias_Id : constant Entity_Id := Ultimate_Alias (Prim);
Loc : constant Source_Ptr := Sloc (R);
- Par_R : constant Node_Id := Parent (R);
- New_Body : Node_Id;
- New_Decl : Node_Id;
- New_Id : Entity_Id;
- New_Spec : Node_Id;
+ DTW_Body : Node_Id;
+ DTW_Decl : Node_Id;
+ DTW_Id : Entity_Id;
+ DTW_Spec : Node_Id;
begin
-- The wrapper must be analyzed in the scope of its wrapped
@@ -1665,47 +1912,130 @@
Push_Scope (Scope (Prim));
- New_Spec := Build_Overriding_Spec (Par_Prim, R);
- New_Id := Defining_Entity (New_Spec);
- New_Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification => New_Spec);
+ DTW_Spec := Build_DTW_Spec (Par_Prim);
+ DTW_Id := Defining_Entity (DTW_Spec);
+ DTW_Decl := Make_Subprogram_Declaration (Loc,
+ Specification => DTW_Spec);
- -- Insert the declaration and the body of the wrapper after
- -- type declaration that generates inherited operation. For
- -- a null procedure, the declaration implies a null body.
+ -- For inherited class-wide preconditions the DTW wrapper
+ -- reuses the ICW of the parent (which checks the parent
+ -- interpretation of the class-wide preconditions); the
+ -- interpretation of the class-wide preconditions for the
+ -- inherited subprogram is checked at the caller side.
- -- Before insertion, do some minimal decoration of fields
+ -- When the subprogram inherits class-wide postconditions
+ -- the DTW also checks the interpretation of the class-wide
+ -- postconditions for the inherited subprogram, and the body
+ -- of the parent checks its interpretation of the parent for
+ -- the class-wide postconditions.
- Mutate_Ekind (New_Id, Ekind (Par_Prim));
- Set_LSP_Subprogram (New_Id, Par_Prim);
- Set_Is_Wrapper (New_Id);
+ -- procedure Prim (F1 : T1; ...) is
+ -- [ pragma Check (Postcondition, Expr); ]
+ -- begin
+ -- Par_Prim_ICW (Par_Type (F1), ...);
+ -- end;
- if Nkind (New_Spec) = N_Procedure_Specification
- and then Null_Present (New_Spec)
- then
- Insert_After_And_Analyze (Par_R, New_Decl);
+ if Present (Indirect_Call_Wrapper (Par_Prim)) then
+ DTW_Body :=
+ Build_DTW_Body (Loc,
+ DTW_Spec => DTW_Spec,
+ DTW_Decls => Decls,
+ Par_Prim => Par_Prim,
+ Wrapped_Subp => Indirect_Call_Wrapper (Par_Prim));
+
+ -- For subprograms that only inherit class-wide postconditions
+ -- the DTW wrapper calls the parent primitive (which on its
+ -- body checks the interpretation of the class-wide post-
+ -- conditions for the parent subprogram), and the DTW checks
+ -- the interpretation of the class-wide postconditions for the
+ -- inherited subprogram.
+
+ -- procedure Prim (F1 : T1; ...) is
+ -- pragma Check (Postcondition, Expr);
+ -- begin
+ -- Par_Prim (Par_Type (F1), ...);
+ -- end;
else
- -- Build body as wrapper to a call to the already built
- -- class-wide clone.
-
- New_Body :=
- Build_Class_Wide_Clone_Call
- (Loc, Decls, Par_Prim, New_Spec);
-
- Insert_List_After_And_Analyze
- (Par_R, New_List (New_Decl, New_Body));
-
- -- Ensure correct decoration
-
- pragma Assert (Present (Alias (Prim)));
- pragma Assert (Present (Overridden_Operation (New_Id)));
- pragma Assert (Overridden_Operation (New_Id) = Alias_Id);
+ DTW_Body :=
+ Build_DTW_Body (Loc,
+ DTW_Spec => DTW_Spec,
+ DTW_Decls => Decls,
+ Par_Prim => Par_Prim,
+ Wrapped_Subp => Par_Prim);
end if;
- pragma Assert (Is_Dispatching_Operation (Prim));
- pragma Assert (Is_Dispatching_Operation (New_Id));
+ -- Insert the declaration of the wrapper before the freezing
+ -- node of the record type declaration to ensure that it will
+ -- override the internal primitive built by Derive_Subprogram.
+
+ Ensure_Freeze_Node (R);
+
+ if Late_Overriding then
+ Insert_Before_And_Analyze (Freeze_Node (R), DTW_Decl);
+ else
+ Append_Freeze_Action (R, DTW_Decl);
+ end if;
+
+ Analyze (DTW_Decl);
+
+ -- Insert the body of the wrapper in the freeze actions of
+ -- its record type declaration to ensure that it is placed
+ -- in the scope of its declaration but not too early to cause
+ -- premature freezing of other entities.
+
+ Append_Freeze_Action (R, DTW_Body);
+ Analyze (DTW_Body);
+
+ -- Ensure correct decoration
+
+ pragma Assert (Is_Dispatching_Operation (DTW_Id));
+ pragma Assert (Present (Overridden_Operation (DTW_Id)));
+ pragma Assert (Overridden_Operation (DTW_Id) = Alias_Id);
+
+ -- Inherit dispatch table slot
+
+ Set_DTC_Entity_Value (R, DTW_Id);
+ Set_DT_Position (DTW_Id, DT_Position (Alias_Id));
+
+ -- Register the wrapper in the dispatch table
+
+ if Late_Overriding
+ and then not Building_Static_DT (R)
+ then
+ Insert_List_After_And_Analyze (Freeze_Node (R),
+ Register_Primitive (Loc, DTW_Id));
+ end if;
+
+ -- Build the helper and ICW for the DTW
+
+ if Present (Indirect_Call_Wrapper (Par_Prim)) then
+ declare
+ CW_Subp : Entity_Id;
+ Decl_N : Node_Id;
+ Body_N : Node_Id;
+
+ begin
+ Merge_Class_Conditions (DTW_Id);
+ Make_Class_Precondition_Subps (DTW_Id,
+ Late_Overriding => Late_Overriding);
+
+ CW_Subp := Static_Call_Helper (DTW_Id);
+ Decl_N := Unit_Declaration_Node (CW_Subp);
+ Analyze (Decl_N);
+
+ -- If the DTW was built for a late-overriding primitive
+ -- its body must be analyzed now (since the tagged type
+ -- is already frozen).
+
+ if Late_Overriding then
+ Body_N :=
+ Unit_Declaration_Node
+ (Corresponding_Body (Decl_N));
+ Analyze (Body_N);
+ end if;
+ end;
+ end if;
Pop_Scope;
end;
@@ -7398,7 +7728,7 @@
if Is_Type (E) then
Freeze_And_Append (First_Subtype (E), N, Result);
- -- If we just froze a tagged non-class wide record, then freeze the
+ -- If we just froze a tagged non-class-wide record, then freeze the
-- corresponding class-wide type. This must be done after the tagged
-- type itself is frozen, because the class-wide type refers to the
-- tagged type which generates the class.
@@ -10062,7 +10392,7 @@
-- Warn_Overlay --
------------------
- procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Entity_Id) is
+ procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id) is
Ent : constant Entity_Id := Entity (Nam);
-- The object to which the address clause applies
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index 6f4feca..0174756 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -174,6 +174,15 @@
-- do not allow a size clause if the size would not otherwise be known at
-- compile time in any case.
+ procedure Check_Inherited_Conditions
+ (R : Entity_Id;
+ Late_Overriding : Boolean := False);
+ -- For a tagged derived type R, create wrappers for inherited operations
+ -- that have class-wide conditions, so it can be properly rewritten if
+ -- it involves calls to other overriding primitives. Late_Overriding is
+ -- True when we are processing the body of a primitive with no previous
+ -- spec defined after R is frozen (see Check_Dispatching_Operation).
+
function Is_Full_Access_Aggregate (N : Node_Id) return Boolean;
-- If a full access object is initialized with an aggregate or is assigned
-- an aggregate, we have to prevent a piecemeal access or assignment to the
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index c341e2d..61a627f 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -517,7 +517,6 @@
ada/libgnat/s-excmac.o \
ada/libgnat/s-exctab.o \
ada/libgnat/s-htable.o \
- ada/libgnat/s-imenne.o \
ada/libgnat/s-imgint.o \
ada/libgnat/s-mastop.o \
ada/libgnat/s-memory.o \
@@ -684,7 +683,6 @@
ada/libgnat/s-excmac.o \
ada/libgnat/s-exctab.o \
ada/libgnat/s-htable.o \
- ada/libgnat/s-imenne.o \
ada/libgnat/s-imgint.o \
ada/libgnat/s-mastop.o \
ada/libgnat/s-memory.o \
diff --git a/gcc/ada/gcc-interface/cuintp.c b/gcc/ada/gcc-interface/cuintp.c
index 6ac82d7..abf8d46 100644
--- a/gcc/ada/gcc-interface/cuintp.c
+++ b/gcc/ada/gcc-interface/cuintp.c
@@ -39,6 +39,7 @@
#include "ada.h"
#include "types.h"
#include "uintp.h"
+#include "sinfo.h"
#include "ada-tree.h"
#include "gigi.h"
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 884d1d8..13e9004 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -557,7 +557,7 @@
/* If the entity is an inherited component (in the case of extended
tagged record types), just return the original entity, which must
be a FIELD_DECL. Likewise for discriminants. If the entity is a
- non-girder discriminant (in the case of derived untagged record
+ non-stored discriminant (in the case of derived untagged record
types), return the stored discriminant it renames. */
if (Present (Original_Record_Component (gnat_entity))
&& Original_Record_Component (gnat_entity) != gnat_entity)
@@ -6503,7 +6503,8 @@
Node_Id gnat_scalar_range;
tree gnu_lb, gnu_hb, gnu_lb_minus_one;
- /* If the low bound is not constant, try to find an upper bound. */
+ /* If the low bound is not constant, take the worst case by finding an upper
+ bound for its type, repeatedly if need be. */
while (Nkind (gnat_lb) != N_Integer_Literal
&& (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
|| Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
@@ -6512,7 +6513,8 @@
|| Nkind (gnat_scalar_range) == N_Range))
gnat_lb = High_Bound (gnat_scalar_range);
- /* If the high bound is not constant, try to find a lower bound. */
+ /* If the high bound is not constant, take the worst case by finding a lower
+ bound for its type, repeatedly if need be. */
while (Nkind (gnat_hb) != N_Integer_Literal
&& (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
|| Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 49b85a4..692ef44 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -234,7 +234,7 @@
extern void gigi (Node_Id gnat_root,
int max_gnat_node,
int number_name,
- Field_Offset *node_offsets_ptr,
+ Node_Header *node_offsets_ptr,
any_slot *slots_ptr,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
diff --git a/gcc/ada/gcc-interface/targtyps.c b/gcc/ada/gcc-interface/targtyps.c
index 704172d..fb103a1 100644
--- a/gcc/ada/gcc-interface/targtyps.c
+++ b/gcc/ada/gcc-interface/targtyps.c
@@ -34,6 +34,7 @@
#include "ada.h"
#include "types.h"
+#include "sinfo.h"
#include "ada-tree.h"
#include "gigi.h"
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index d3c421d..3fec060 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -75,7 +75,7 @@
#define ALLOCA_THRESHOLD 1000
/* Pointers to front-end tables accessed through macros. */
-Field_Offset *Node_Offsets_Ptr;
+Node_Header *Node_Offsets_Ptr;
any_slot *Slots_Ptr;
Node_Id *Next_Node_Ptr;
Node_Id *Prev_Node_Ptr;
@@ -279,7 +279,7 @@
gigi (Node_Id gnat_root,
int max_gnat_node,
int number_name ATTRIBUTE_UNUSED,
- Field_Offset *node_offsets_ptr,
+ Node_Header *node_offsets_ptr,
any_slot *slots_ptr,
Node_Id *next_node_ptr,
Node_Id *prev_node_ptr,
@@ -3893,7 +3893,7 @@
/* If the body comes from an expression function, arrange it to be inlined
in almost all cases. */
- if (Was_Expression_Function (gnat_node))
+ if (Was_Expression_Function (gnat_node) && !Debug_Flag_Dot_8)
DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl) = 1;
/* Try to create a bona-fide thunk and hand it over to the middle-end. */
@@ -8261,6 +8261,7 @@
|| kind == N_Selected_Component)
&& TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
&& Nkind (Parent (gnat_node)) != N_Attribute_Reference
+ && Nkind (Parent (gnat_node)) != N_Pragma_Argument_Association
&& Nkind (Parent (gnat_node)) != N_Variant_Part
&& !lvalue_required_p (gnat_node, gnu_result_type, false, false))
{
@@ -10507,10 +10508,15 @@
case N_Package_Body:
case N_Subprogram_Body:
case N_Block_Statement:
- gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
+ if (Present (Handled_Statement_Sequence (gnat_node)))
+ gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
+ else
+ gnat_end_label = Empty;
+
break;
case N_Package_Declaration:
+ gcc_checking_assert (Present (Specification (gnat_node)));
gnat_end_label = End_Label (Specification (gnat_node));
break;
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index be3f107..ab5ca5b 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -94,6 +94,7 @@
static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *);
static tree handle_stack_protect_attribute (tree *, tree, tree, int, bool *);
static tree handle_no_stack_protector_attribute (tree *, tree, tree, int, bool *);
+static tree handle_strub_attribute (tree *, tree, tree, int, bool *);
static tree handle_noinline_attribute (tree *, tree, tree, int, bool *);
static tree handle_noclone_attribute (tree *, tree, tree, int, bool *);
static tree handle_noicf_attribute (tree *, tree, tree, int, bool *);
@@ -157,6 +158,8 @@
{ "no_stack_protector",0, 0, true, false, false, false,
handle_no_stack_protector_attribute,
attr_stack_protect_exclusions },
+ { "strub", 0, 1, false, true, false, true,
+ handle_strub_attribute, NULL },
{ "noinline", 0, 0, true, false, false, false,
handle_noinline_attribute, NULL },
{ "noclone", 0, 0, true, false, false, false,
@@ -6602,6 +6605,15 @@
return NULL_TREE;
}
+/* Handle a "strub" attribute; arguments as in
+ struct attribute_spec.handler. */
+
+static tree
+handle_strub_attribute (tree *, tree, tree, int, bool *no_add_attrs)
+{
+ *no_add_attrs = true;
+ return NULL_TREE;
+}
/* Handle a "noinline" attribute; arguments as in
struct attribute_spec.handler. */
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 360e2e1..f3f3ca4 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -23,8 +23,6 @@
-- --
------------------------------------------------------------------------------
-with Gen_IL.Types;
-
package Gen_IL.Fields is
-- The following is "optional field enumeration" -- i.e. it is Field_Enum
@@ -36,8 +34,7 @@
-- which might need to be kept in sync when modifying this.
-- Be sure to put new fields in the appropriate subrange (Field_Enum,
- -- Node_Header_Field, Node_Field, Entity_Field -- search for comments
- -- below).
+ -- Node_Field, Entity_Field -- search for comments below).
type Opt_Field_Enum is
(No_Field,
@@ -461,7 +458,9 @@
Can_Never_Be_Null,
Can_Use_Internal_Rep,
Checks_May_Be_Suppressed,
- Class_Wide_Clone,
+ Class_Postconditions,
+ Class_Preconditions,
+ Class_Preconditions_Subprogram,
Class_Wide_Type,
Cloned_Subtype,
Component_Alignment,
@@ -509,6 +508,7 @@
Discriminant_Default_Value,
Discriminant_Number,
Dispatch_Table_Wrappers,
+ Dynamic_Call_Helper,
DT_Entry_Count,
DT_Offset_To_Top_Func,
DT_Position,
@@ -649,9 +649,12 @@
Hiding_Loop_Variable,
Hidden_In_Formal_Instance,
Homonym,
+ Ignored_Class_Postconditions,
+ Ignored_Class_Preconditions,
Ignore_SPARK_Mode_Pragmas,
Import_Pragma,
Incomplete_Actuals,
+ Indirect_Call_Wrapper,
In_Package_Body,
In_Private_Part,
In_Use,
@@ -677,6 +680,7 @@
Is_Checked_Ghost_Entity,
Is_Child_Unit,
Is_Class_Wide_Equivalent_Type,
+ Is_Class_Wide_Wrapper,
Is_Compilation_Unit,
Is_Completely_Hidden,
Is_Concurrent_Record_Type,
@@ -693,6 +697,7 @@
Is_Discrim_SO_Function,
Is_Discriminant_Check_Function,
Is_Dispatch_Table_Entity,
+ Is_Dispatch_Table_Wrapper,
Is_Dispatching_Operation,
Is_Elaboration_Checks_OK_Id,
Is_Elaboration_Warnings_OK_Id,
@@ -892,6 +897,7 @@
Spec_Entity,
SSO_Set_High_By_Default,
SSO_Set_Low_By_Default,
+ Static_Call_Helper,
Static_Discrete_Predicate,
Static_Elaboration_Desired,
Static_Initialization,
@@ -935,13 +941,4 @@
-- Enumeration of fields -- Opt_Field_Enum without the special null value
-- No_Field.
- subtype Node_Header_Field is Field_Enum with Predicate =>
- Node_Header_Field in Nkind .. Link | Ekind;
-
- use Gen_IL.Types;
-
- subtype Node_Header_Type is Type_Enum range
- Node_Kind_Type .. Union_Id;
- -- Types of node header fields
-
end Gen_IL.Fields;
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index bca0549..1fa7f0b 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -126,6 +126,7 @@
Sm (Is_Character_Type, Flag),
Sm (Is_Checked_Ghost_Entity, Flag),
Sm (Is_Child_Unit, Flag),
+ Sm (Is_Class_Wide_Wrapper, Flag),
Sm (Is_Class_Wide_Equivalent_Type, Flag),
Sm (Is_Compilation_Unit, Flag),
Sm (Is_Concurrent_Record_Type, Flag),
@@ -139,6 +140,7 @@
Sm (Is_Discrim_SO_Function, Flag),
Sm (Is_Discriminant_Check_Function, Flag),
Sm (Is_Dispatch_Table_Entity, Flag),
+ Sm (Is_Dispatch_Table_Wrapper, Flag),
Sm (Is_Dispatching_Operation, Flag),
Sm (Is_Eliminated, Flag),
Sm (Is_Entry_Formal, Flag),
@@ -977,8 +979,11 @@
Ab (Subprogram_Kind, Overloadable_Kind,
(Sm (Body_Needed_For_SAL, Flag),
- Sm (Class_Wide_Clone, Node_Id),
+ Sm (Class_Postconditions, Node_Id),
+ Sm (Class_Preconditions, Node_Id),
+ Sm (Class_Preconditions_Subprogram, Node_Id),
Sm (Contract, Node_Id),
+ Sm (Dynamic_Call_Helper, Node_Id),
Sm (Elaboration_Entity, Node_Id),
Sm (Elaboration_Entity_Required, Flag),
Sm (First_Entity, Node_Id),
@@ -986,8 +991,11 @@
Sm (Has_Nested_Subprogram, Flag),
Sm (Has_Out_Or_In_Out_Parameter, Flag),
Sm (Has_Recursive_Call, Flag),
+ Sm (Ignored_Class_Postconditions, Node_Id),
+ Sm (Ignored_Class_Preconditions, Node_Id),
Sm (Ignore_SPARK_Mode_Pragmas, Flag),
Sm (Import_Pragma, Node_Id),
+ Sm (Indirect_Call_Wrapper, Node_Id),
Sm (Interface_Alias, Node_Id),
Sm (Interface_Name, Node_Id),
Sm (Is_Elaboration_Checks_OK_Id, Flag),
@@ -998,6 +1006,7 @@
Sm (Overridden_Operation, Node_Id),
Sm (Protected_Body_Subprogram, Node_Id),
Sm (Scope_Depth_Value, Uint),
+ Sm (Static_Call_Helper, Node_Id),
Sm (SPARK_Pragma, Node_Id),
Sm (SPARK_Pragma_Inherited, Flag),
Sm (Subps_Index, Uint)));
@@ -1383,6 +1392,23 @@
(E_Entry,
E_Entry_Family));
+ Union (Evaluable_Kind,
+ Children =>
+ (Exception_Or_Object_Kind,
+ E_Enumeration_Literal,
+ E_Label,
+ Subprogram_Kind));
+ -- Kinds that represent values that can be evaluated
+
+ Union (Global_Name_Kind,
+ Children =>
+ (Constant_Or_Variable_Kind,
+ E_Exception,
+ E_Package,
+ Subprogram_Kind));
+ -- Kinds that can have an Interface_Name that corresponds to a global
+ -- (linker) name.
+
Union (Named_Access_Kind,
Children =>
(E_Access_Type,
@@ -1408,4 +1434,10 @@
E_Record_Type_With_Private,
E_Record_Subtype_With_Private));
+ Union (Subprogram_Type_Or_Kind,
+ Children =>
+ (Subprogram_Kind,
+ E_Subprogram_Body,
+ E_Subprogram_Type));
+
end Gen_IL.Gen.Gen_Entities;
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 55ba71d..20d25ea 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -577,7 +577,8 @@
Ab (N_Declaration, Node_Kind);
-- Note: this includes all constructs normally thought of as declarations
- -- except those that are separately grouped in N_Later_Decl_Item.
+ -- except those that are separately grouped in N_Later_Decl_Item. But
+ -- Declaration_Node may return yet more node types; see N_Is_Decl below.
Cc (N_Component_Declaration, N_Declaration,
(Sy (Defining_Identifier, Node_Id),
@@ -1649,4 +1650,67 @@
N_Terminate_Alternative));
-- Nodes with condition fields (does not include N_Raise_xxx_Error)
+ Union (N_Has_Bounds,
+ Children =>
+ (N_Range,
+ N_Real_Range_Specification,
+ N_Signed_Integer_Type_Definition));
+ -- Nodes that have Low_Bound and High_Bound defined
+
+ Union (N_Is_Index,
+ Children =>
+ (N_Has_Bounds,
+ N_Has_Entity,
+ N_Subtype_Indication));
+ -- Nodes that can be an index of an array
+
+ Union (N_Entity_Name,
+ Children =>
+ (N_Expanded_Name,
+ N_Identifier,
+ N_Operator_Symbol));
+ -- Nodes that are definitely representing an entity.
+ -- Some N_Attribute_Reference nodes may also represent an entity. See
+ -- Is_Entity_Name.
+
+ Union (N_Is_Decl,
+ Children =>
+ (N_Declaration,
+ N_Discriminant_Specification,
+ N_Enumeration_Type_Definition,
+ N_Exception_Handler,
+ N_Later_Decl_Item,
+ N_Package_Specification,
+ N_Parameter_Specification,
+ N_Renaming_Declaration,
+ N_Subprogram_Specification));
+ -- Nodes that can be returned by Declaration_Node
+
+ Union (N_Is_Range,
+ Children =>
+ (N_Character_Literal,
+ N_Entity_Name,
+ N_Has_Bounds,
+ N_Integer_Literal,
+ N_Subtype_Indication));
+ -- Nodes that can be used to specify a range
+
+ Union (N_Is_Case_Choice,
+ Children =>
+ (N_Is_Range,
+ N_Others_Choice));
+ -- Nodes that can be in the choices of a case statement
+
+ Union (N_Is_Exception_Choice,
+ Children =>
+ (N_Entity_Name,
+ N_Others_Choice));
+ -- Nodes that can be in the choices of an exception handler
+
+ Union (N_Alternative,
+ Children =>
+ (N_Case_Statement_Alternative,
+ N_Variant));
+ -- Nodes that can be alternatives in case contructs
+
end Gen_IL.Gen.Gen_Nodes;
diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb
index 3bb9807..e786251 100644
--- a/gcc/ada/gen_il-gen.adb
+++ b/gcc/ada/gen_il-gen.adb
@@ -28,6 +28,27 @@
package body Gen_IL.Gen is
+ Statistics_Enabled : constant Boolean := False;
+ -- Change to True or False to enable/disable statistics printed by
+ -- Atree. Should normally be False, for efficiency. Also compile with
+ -- -gnatd.A to get the statistics printed. Enabling these statistics
+ -- makes the compiler about 20% slower.
+
+ Num_Header_Slots : constant := 3;
+ -- Number of header slots; the first Num_Header_Slots slots are stored in
+ -- the header; the rest are dynamically allocated in the Slots table. We
+ -- need to subtract this off when accessing dynamic slots. The constant
+ -- Seinfo.N_Head will contain this value. Fields that are allocated in the
+ -- header slots are quicker to access.
+ --
+ -- This number can be adjusted for efficiency. We choose 3 because the
+ -- minimum node size is 3 slots, and because that causes the size of type
+ -- Node_Header to be a power of 2. We can't make it zero, however, because
+ -- C doesn't allow zero-length arrays.
+
+ N_Head : constant String := Image (Field_Offset'(Num_Header_Slots));
+ -- String form of the above
+
Enable_Assertions : constant Boolean := True;
-- True to enable predicates on the _Id types, and preconditions on getters
-- and setters.
@@ -37,6 +58,9 @@
-- which results in enormous nodes. For experimenting and debugging.
-- Should be True in normal operation, for efficiency.
+ SS : constant := 32; -- slot size in bits
+ SSS : constant String := Image (Bit_Offset'(SS));
+
Inline : constant String := "Inline";
-- For experimenting with Inline_Always
@@ -309,7 +333,7 @@
Pre => new String'(Pre),
Pre_Get => new String'(Pre_Get),
Pre_Set => new String'(Pre_Set),
- Offset => <>); -- filled in later
+ Offset => Unknown_Offset);
-- The Field_Table entry has already been created by the 'then' part
-- above. Now we're seeing the same field being "created" again in a
@@ -479,8 +503,6 @@
Min_Entity_Size : Field_Offset := Field_Offset'Last;
Max_Entity_Size : Field_Offset := 0;
- Average_Node_Size_In_Slots : Long_Float;
-
Node_Field_Types_Used, Entity_Field_Types_Used : Type_Set;
Setter_Needs_Parent : Field_Set :=
@@ -563,6 +585,8 @@
procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum);
procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum);
procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum);
+ procedure Put_Getter_Setter_Locals
+ (S : in out Sink; F : Field_Enum; Get : Boolean);
procedure Put_Getter_Body (S : in out Sink; F : Field_Enum);
procedure Put_Setter_Body (S : in out Sink; F : Field_Enum);
-- Print out the specification, declaration, or body of a getter or
@@ -573,9 +597,9 @@
-- Print out the precondition, if any, for a getter or setter for the
-- given field.
- procedure Put_Low_Level_Accessor_Instantiations
+ procedure Put_Casts
(S : in out Sink; T : Type_Enum);
- -- Print out the low-level getter and setter for a given type
+ -- Print out the Cast functions for a given type
procedure Put_Traversed_Fields (S : in out Sink);
-- Called by Put_Nodes to print out the Traversed_Fields table in
@@ -616,22 +640,17 @@
-- corresponding to the Ada Node_Kind, Entity_Kind, and subtypes
-- thereof.
- procedure Put_Low_Level_C_Getter
- (S : in out Sink; T : Type_Enum);
- -- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out low-level
- -- getters.
-
- procedure Put_High_Level_C_Getters
+ procedure Put_C_Getters
(S : in out Sink; Root : Root_Type);
-- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out high-level
-- getters.
- procedure Put_High_Level_C_Getter
+ procedure Put_C_Getter
(S : in out Sink; F : Field_Enum);
- -- Used by Put_High_Level_C_Getters to print out one high-level getter.
+ -- Used by Put_C_Getters to print out one high-level getter.
procedure Put_Union_Membership
- (S : in out Sink; Root : Root_Type);
+ (S : in out Sink; Root : Root_Type; Only_Prototypes : Boolean);
-- Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out functions to
-- test membership in a union type.
@@ -691,6 +710,8 @@
Type_Table (T).Last := T;
Add_Concrete_Descendant_To_Ancestors
(Type_Table (T).Parent, T);
+ -- Parent cannot be No_Type here, because T is a concrete
+ -- type, and therefore not a root type.
when Abstract_Type =>
declare
@@ -884,13 +905,13 @@
function To_Size_In_Slots (Size_In_Bits : Bit_Offset)
return Field_Offset is
- ((Field_Offset (Size_In_Bits) + 31) / 32);
+ ((Field_Offset (Size_In_Bits) + (SS - 1)) / SS);
function Type_Size_In_Slots (T : Concrete_Type) return Field_Offset is
(To_Size_In_Slots (Type_Bit_Size (T))); -- rounded up to slot boundary
function Type_Bit_Size_Aligned (T : Concrete_Type) return Bit_Offset is
- (Bit_Offset (Type_Size_In_Slots (T)) * 32); -- multiple of slot size
+ (Bit_Offset (Type_Size_In_Slots (T)) * SS); -- multiple of slot size
---------------------------
-- Compute_Field_Offsets --
@@ -924,8 +945,7 @@
(F : Field_Enum; Offset : Field_Offset);
-- Mark the offset as "in use"
- function Choose_Offset
- (F : Field_Enum) return Field_Offset;
+ procedure Choose_Offset (F : Field_Enum);
-- Choose an offset for this field
function Offset_OK
@@ -965,14 +985,14 @@
end loop;
end Set_Offset_In_Use;
- function Choose_Offset
- (F : Field_Enum) return Field_Offset is
+ procedure Choose_Offset (F : Field_Enum) is
begin
for Offset in Field_Offset loop
if Offset_OK (F, Offset) then
Set_Offset_In_Use (F, Offset);
- return Offset;
+ Field_Table (F).Offset := Offset;
+ return;
end if;
end loop;
@@ -981,16 +1001,16 @@
Image (Gen_IL.Internals.Bit_Offset'Last) & " is too small)";
end Choose_Offset;
- Num_Concrete_Have_Field : array (Field_Enum) of Type_Count :=
+ Weighted_Node_Frequency : array (Field_Enum) of Type_Count :=
(others => 0);
-- Number of concrete types that have each field
function More_Types_Have_Field (F1, F2 : Field_Enum) return Boolean is
- (Num_Concrete_Have_Field (F1) > Num_Concrete_Have_Field (F2));
+ (Weighted_Node_Frequency (F1) > Weighted_Node_Frequency (F2));
-- True if F1 appears in more concrete types than F2
function Sort_Less (F1, F2 : Field_Enum) return Boolean is
- (if Num_Concrete_Have_Field (F1) = Num_Concrete_Have_Field (F2) then
+ (if Weighted_Node_Frequency (F1) = Weighted_Node_Frequency (F2) then
F1 < F2
else More_Types_Have_Field (F1, F2));
@@ -999,15 +1019,18 @@
All_Fields : Field_Vector;
+ -- Start of processing for Compute_Field_Offsets
+
begin
- -- Compute the number of types that have each field
+ -- Compute the number of types that have each field, weighted by the
+ -- frequency of such nodes.
for T in Concrete_Type loop
for F in Field_Enum loop
if Fields_Per_Node (T) (F) then
- Num_Concrete_Have_Field (F) :=
- Num_Concrete_Have_Field (F) + 1;
+ Weighted_Node_Frequency (F) :=
+ Weighted_Node_Frequency (F) + Type_Frequency (T);
end if;
end loop;
end loop;
@@ -1038,8 +1061,33 @@
-- complication compared to standard graph coloring is that fields
-- are different sizes.
+ -- First choose offsets for some heavily-used fields, so they will
+ -- get low offsets, so they will wind up in the node header for
+ -- faster access.
+
+ Choose_Offset (Nkind);
+ pragma Assert (Field_Table (Nkind).Offset = 0);
+ Choose_Offset (Ekind);
+ pragma Assert (Field_Table (Ekind).Offset = 1);
+ Choose_Offset (Homonym);
+ pragma Assert (Field_Table (Homonym).Offset = 1);
+ Choose_Offset (Is_Immediately_Visible);
+ pragma Assert (Field_Table (Is_Immediately_Visible).Offset = 16);
+ Choose_Offset (From_Limited_With);
+ pragma Assert (Field_Table (From_Limited_With).Offset = 17);
+ Choose_Offset (Is_Potentially_Use_Visible);
+ pragma Assert (Field_Table (Is_Potentially_Use_Visible).Offset = 18);
+ Choose_Offset (Is_Generic_Instance);
+ pragma Assert (Field_Table (Is_Generic_Instance).Offset = 19);
+ Choose_Offset (Scope);
+ pragma Assert (Field_Table (Scope).Offset = 2);
+
+ -- Then loop through them all, skipping the ones we did above
+
for F of All_Fields loop
- Field_Table (F).Offset := Choose_Offset (F);
+ if Field_Table (F).Offset = Unknown_Offset then
+ Choose_Offset (F);
+ end if;
end loop;
end Compute_Field_Offsets;
@@ -1049,231 +1097,6 @@
------------------------
procedure Compute_Type_Sizes is
- -- Node_Counts is the number of nodes of each kind created during
- -- compilation of a large example. This is used purely to compute an
- -- estimate of the average node size. New node types can default to
- -- "others => 0". At some point we can instrument Atree to print out
- -- accurate size statistics, and remove this code.
-
- Node_Counts : constant array (Concrete_Node) of Natural :=
- (N_Identifier => 429298,
- N_Defining_Identifier => 231636,
- N_Integer_Literal => 90892,
- N_Parameter_Specification => 62811,
- N_Attribute_Reference => 47150,
- N_Expanded_Name => 37375,
- N_Selected_Component => 30699,
- N_Subprogram_Declaration => 20744,
- N_Freeze_Entity => 20314,
- N_Procedure_Specification => 18901,
- N_Object_Declaration => 18023,
- N_Function_Specification => 16570,
- N_Range => 16216,
- N_Explicit_Dereference => 12198,
- N_Component_Association => 11188,
- N_Unchecked_Type_Conversion => 11165,
- N_Subtype_Indication => 10727,
- N_Procedure_Call_Statement => 10056,
- N_Subtype_Declaration => 8141,
- N_Handled_Sequence_Of_Statements => 8078,
- N_Null => 7288,
- N_Aggregate => 7222,
- N_String_Literal => 7152,
- N_Function_Call => 6958,
- N_Simple_Return_Statement => 6911,
- N_And_Then => 6867,
- N_Op_Eq => 6845,
- N_Call_Marker => 6683,
- N_Pragma_Argument_Association => 6525,
- N_Component_Definition => 6487,
- N_Assignment_Statement => 6483,
- N_With_Clause => 6480,
- N_Null_Statement => 5917,
- N_Index_Or_Discriminant_Constraint => 5877,
- N_Generic_Association => 5667,
- N_Full_Type_Declaration => 5573,
- N_If_Statement => 5553,
- N_Subprogram_Body => 5455,
- N_Op_Add => 5443,
- N_Type_Conversion => 5260,
- N_Component_Declaration => 5059,
- N_Raise_Constraint_Error => 4840,
- N_Formal_Concrete_Subprogram_Declaration => 4602,
- N_Expression_With_Actions => 4598,
- N_Op_Ne => 3854,
- N_Indexed_Component => 3834,
- N_Op_Subtract => 3777,
- N_Package_Specification => 3490,
- N_Subprogram_Renaming_Declaration => 3445,
- N_Pragma => 3427,
- N_Case_Statement_Alternative => 3272,
- N_Block_Statement => 3239,
- N_Parameter_Association => 3213,
- N_Op_Lt => 3020,
- N_Op_Not => 2926,
- N_Character_Literal => 2914,
- N_Others_Choice => 2769,
- N_Or_Else => 2576,
- N_Itype_Reference => 2511,
- N_Defining_Operator_Symbol => 2487,
- N_Component_List => 2470,
- N_Formal_Object_Declaration => 2262,
- N_Generic_Subprogram_Declaration => 2227,
- N_Real_Literal => 2156,
- N_Op_Gt => 2156,
- N_Access_To_Object_Definition => 1984,
- N_Op_Le => 1975,
- N_Op_Ge => 1942,
- N_Package_Renaming_Declaration => 1811,
- N_Formal_Type_Declaration => 1756,
- N_Qualified_Expression => 1746,
- N_Package_Declaration => 1729,
- N_Record_Definition => 1651,
- N_Allocator => 1521,
- N_Op_Concat => 1377,
- N_Access_Definition => 1358,
- N_Case_Statement => 1322,
- N_Number_Declaration => 1316,
- N_Generic_Package_Declaration => 1311,
- N_Slice => 1078,
- N_Constrained_Array_Definition => 1068,
- N_Exception_Renaming_Declaration => 1011,
- N_Implicit_Label_Declaration => 978,
- N_Exception_Handler => 966,
- N_Private_Type_Declaration => 898,
- N_Operator_Symbol => 872,
- N_Formal_Private_Type_Definition => 867,
- N_Range_Constraint => 849,
- N_Aspect_Specification => 837,
- N_Variant => 834,
- N_Discriminant_Specification => 746,
- N_Loop_Statement => 744,
- N_Derived_Type_Definition => 731,
- N_Freeze_Generic_Entity => 702,
- N_Iteration_Scheme => 686,
- N_Package_Instantiation => 658,
- N_Loop_Parameter_Specification => 632,
- N_Attribute_Definition_Clause => 608,
- N_Compilation_Unit_Aux => 599,
- N_Compilation_Unit => 599,
- N_Label => 572,
- N_Goto_Statement => 572,
- N_In => 564,
- N_Enumeration_Type_Definition => 523,
- N_Object_Renaming_Declaration => 482,
- N_If_Expression => 476,
- N_Exception_Declaration => 472,
- N_Reference => 455,
- N_Incomplete_Type_Declaration => 438,
- N_Use_Package_Clause => 401,
- N_Unconstrained_Array_Definition => 360,
- N_Variant_Part => 340,
- N_Defining_Program_Unit_Name => 336,
- N_Op_And => 334,
- N_Raise_Program_Error => 329,
- N_Formal_Discrete_Type_Definition => 319,
- N_Contract => 311,
- N_Not_In => 305,
- N_Designator => 285,
- N_Component_Clause => 247,
- N_Formal_Signed_Integer_Type_Definition => 244,
- N_Raise_Statement => 214,
- N_Op_Expon => 205,
- N_Op_Minus => 202,
- N_Op_Multiply => 158,
- N_Exit_Statement => 130,
- N_Function_Instantiation => 129,
- N_Discriminant_Association => 123,
- N_Private_Extension_Declaration => 119,
- N_Extended_Return_Statement => 117,
- N_Op_Divide => 107,
- N_Op_Or => 103,
- N_Signed_Integer_Type_Definition => 101,
- N_Record_Representation_Clause => 76,
- N_Unchecked_Expression => 70,
- N_Op_Abs => 63,
- N_Elsif_Part => 62,
- N_Formal_Floating_Point_Definition => 59,
- N_Formal_Package_Declaration => 58,
- N_Modular_Type_Definition => 55,
- N_Abstract_Subprogram_Declaration => 52,
- N_Validate_Unchecked_Conversion => 49,
- N_Defining_Character_Literal => 36,
- N_Raise_Storage_Error => 33,
- N_Compound_Statement => 29,
- N_Procedure_Instantiation => 28,
- N_Access_Procedure_Definition => 25,
- N_Floating_Point_Definition => 20,
- N_Use_Type_Clause => 19,
- N_Op_Plus => 14,
- N_Package_Body => 13,
- N_Op_Rem => 13,
- N_Enumeration_Representation_Clause => 13,
- N_Access_Function_Definition => 11,
- N_Extension_Aggregate => 11,
- N_Formal_Ordinary_Fixed_Point_Definition => 10,
- N_Op_Mod => 10,
- N_Expression_Function => 9,
- N_Delay_Relative_Statement => 9,
- N_Quantified_Expression => 7,
- N_Formal_Derived_Type_Definition => 7,
- N_Free_Statement => 7,
- N_Iterator_Specification => 5,
- N_Op_Shift_Left => 5,
- N_Formal_Modular_Type_Definition => 4,
- N_Generic_Package_Renaming_Declaration => 1,
- N_Empty => 1,
- N_Real_Range_Specification => 1,
- N_Ordinary_Fixed_Point_Definition => 1,
- N_Op_Shift_Right => 1,
- N_Error => 1,
- N_Mod_Clause => 1,
- others => 0);
-
- Total_Node_Count : constant Long_Float := 1370676.0;
-
- type Node_Frequency_Table is array (Concrete_Node) of Long_Float;
-
- function Init_Node_Frequency return Node_Frequency_Table;
- -- Compute the value of the Node_Frequency table
-
- function Average_Type_Size_In_Slots return Long_Float;
- -- Compute the average over all concrete node types of the size,
- -- weighted by the frequency of that node type.
-
- function Init_Node_Frequency return Node_Frequency_Table is
- Result : Node_Frequency_Table := (others => 0.0);
-
- begin
- for T in Concrete_Node loop
- Result (T) := Long_Float (Node_Counts (T)) / Total_Node_Count;
- end loop;
-
- return Result;
- end Init_Node_Frequency;
-
- Node_Frequency : constant Node_Frequency_Table := Init_Node_Frequency;
- -- Table mapping concrete node types to the relative frequency of
- -- that node, in our large example. The sum of these values should
- -- add up to approximately 1.0. For example, if Node_Frequency(K) =
- -- 0.02, then that means that approximately 2% of all nodes are K
- -- nodes.
-
- function Average_Type_Size_In_Slots return Long_Float is
- -- We don't have data on entities, so we leave those out
-
- Result : Long_Float := 0.0;
- begin
- for T in Concrete_Node loop
- Result := Result +
- Node_Frequency (T) * Long_Float (Type_Size_In_Slots (T));
- end loop;
-
- return Result;
- end Average_Type_Size_In_Slots;
-
- -- Start of processing for Compute_Type_Sizes
-
begin
for T in Concrete_Type loop
declare
@@ -1289,7 +1112,10 @@
end if;
end loop;
- Type_Bit_Size (T) := Max_Offset + 1;
+ -- No type can be smaller than the header slots
+
+ Type_Bit_Size (T) :=
+ Bit_Offset'Max (Max_Offset + 1, SS * Num_Header_Slots);
end;
end loop;
@@ -1311,8 +1137,6 @@
Max_Node_Size := To_Size_In_Slots (Max_Node_Bit_Size);
Min_Entity_Size := To_Size_In_Slots (Min_Entity_Bit_Size);
Max_Entity_Size := To_Size_In_Slots (Max_Entity_Bit_Size);
-
- Average_Node_Size_In_Slots := Average_Type_Size_In_Slots;
end Compute_Type_Sizes;
----------------------------------------
@@ -1533,7 +1357,7 @@
case Root is
when Node_Kind =>
Put_Getter_Decl (S, Nkind);
- Put (S, "function K (N : Node_Id) return Node_Kind renames Nkind;" & LF);
+ Put (S, "function K (N : Node_Id) return Node_Kind renames " & Image (Nkind) & ";" & LF);
Put (S, "-- Shorthand for use in predicates and preconditions below" & LF);
Put (S, "-- There is no procedure Set_Nkind." & LF);
Put (S, "-- See Init_Nkind and Mutate_Nkind in Atree." & LF & LF);
@@ -1587,66 +1411,26 @@
Put (S, LF & "subtype Flag is Boolean;" & LF & LF);
end Put_Type_And_Subtypes;
- function Low_Level_Getter_Name (T : Type_Enum) return String is
- ("Get_" & Image (T));
- function Low_Level_Setter_Name (T : Type_Enum) return String is
- ("Set_" & Image (T));
- function Low_Level_Setter_Name (F : Field_Enum) return String is
- (Low_Level_Setter_Name (Field_Table (F).Field_Type) &
- (if Setter_Needs_Parent (F) then "_With_Parent" else ""));
-
-------------------------------------------
- -- Put_Low_Level_Accessor_Instantiations --
+ -- Put_Casts --
-------------------------------------------
- procedure Put_Low_Level_Accessor_Instantiations
+ procedure Put_Casts
(S : in out Sink; T : Type_Enum)
is
+ Pre : constant String :=
+ "function Cast is new Unchecked_Conversion (";
+ Lo_Type : constant String := "Field_Size_" & Image (Field_Size (T)) & "_Bit";
+ Hi_Type : constant String := Get_Set_Id_Image (T);
begin
- -- Special case for subtypes of Uint that have predicates. Use
- -- Get_Valid_32_Bit_Field in that case.
+ if T not in Uint_Subtype then
+ if T not in Node_Kind_Type | Entity_Kind_Type then
+ Put (S, Pre & Hi_Type & ", " & Lo_Type & ");" & LF);
+ end if;
- if T in Uint_Subtype then
- pragma Assert (Field_Size (T) = 32);
- Put (S, LF & "function " & Low_Level_Getter_Name (T) &
- " is new Get_Valid_32_Bit_Field (" &
- Get_Set_Id_Image (T) &
- ") with " & Inline & ";" & LF);
-
- -- Special case for types that have special defaults; instantiate
- -- Get_32_Bit_Field_With_Default and pass in the Default_Val.
-
- elsif Field_Has_Special_Default (T) then
- pragma Assert (Field_Size (T) = 32);
- Put (S, LF & "function " & Low_Level_Getter_Name (T) &
- " is new Get_32_Bit_Field_With_Default (" &
- Get_Set_Id_Image (T) & ", " & Special_Default (T) &
- ") with " & Inline & ";" & LF);
-
- -- Otherwise, instantiate the normal getter for the right size in
- -- bits.
-
- else
- Put (S, LF & "function " & Low_Level_Getter_Name (T) &
- " is new Get_" & Image (Field_Size (T)) & "_Bit_Field (" &
- Get_Set_Id_Image (T) & ") with " & Inline & ";" & LF);
+ Put (S, Pre & Lo_Type & ", " & Hi_Type & ");" & LF);
end if;
-
- if T in Node_Kind_Type | Entity_Kind_Type then
- Put (S, "pragma Warnings (Off);" & LF);
- -- Set_Node_Kind_Type and Set_Entity_Kind_Type might not be called
- end if;
-
- -- No special cases for the setter
-
- Put (S, "procedure " & Low_Level_Setter_Name (T) & " is new Set_" &
- Image (Field_Size (T)) & "_Bit_Field (" & Get_Set_Id_Image (T) &
- ") with " & Inline & ";" & LF);
-
- if T in Node_Kind_Type | Entity_Kind_Type then
- Put (S, "pragma Warnings (On);" & LF);
- end if;
- end Put_Low_Level_Accessor_Instantiations;
+ end Put_Casts;
----------------------
-- Put_Precondition --
@@ -1713,6 +1497,25 @@
-- Node_Id or Entity_Id, and the getter and setter will have
-- preconditions.
+ procedure Put_Get_Set_Incr
+ (S : in out Sink; F : Field_Enum; Get_Or_Set : String)
+ with Pre => Get_Or_Set in "Get" | "Set";
+ -- If statistics are enabled, put the appropriate increment statement
+
+ ----------------------
+ -- Put_Get_Set_Incr --
+ ----------------------
+
+ procedure Put_Get_Set_Incr
+ (S : in out Sink; F : Field_Enum; Get_Or_Set : String) is
+ begin
+ if Statistics_Enabled then
+ Put (S, "Atree." & Get_Or_Set & "_Count (" & F_Image (F) &
+ ") := Atree." & Get_Or_Set & "_Count (" &
+ F_Image (F) & ") + 1;" & LF);
+ end if;
+ end Put_Get_Set_Incr;
+
------------------------
-- Node_To_Fetch_From --
------------------------
@@ -1748,17 +1551,68 @@
Put (S, " with " & Inline);
Increase_Indent (S, 2);
Put_Precondition (S, F);
-
Decrease_Indent (S, 2);
Put (S, ";" & LF);
end Put_Getter_Decl;
+ ------------------------------
+ -- Put_Getter_Setter_Locals --
+ ------------------------------
+
+ procedure Put_Getter_Setter_Locals
+ (S : in out Sink; F : Field_Enum; Get : Boolean)
+ is
+ Rec : Field_Info renames Field_Table (F).all;
+
+ F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
+ Off : constant Field_Offset := Rec.Offset;
+ F_Per_Slot : constant Field_Offset :=
+ SS / Field_Offset (Field_Size (Rec.Field_Type));
+ Slot_Off : constant Field_Offset := Off / F_Per_Slot;
+ In_NH : constant Boolean := Slot_Off < Num_Header_Slots;
+
+ N : constant String :=
+ (if Get then Node_To_Fetch_From (F) else "N");
+
+ begin
+ Put (S, " is" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "-- " & Image (F_Per_Slot) & " " & Image (F_Size) &
+ "-bit fields per " & SSS & "-bit slot." & LF);
+ Put (S, "-- Offset " & Image (Off) & " = " &
+ Image (Slot_Off) & " slots + " & Image (Off mod F_Per_Slot) &
+ " fields in slot." & LF & LF);
+
+ Put (S, "Off : constant := " & Image (Off) & ";" & LF);
+ Put (S, "F_Size : constant := " & Image (F_Size) & ";" & LF);
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "Mask : constant := 2**F_Size - 1;" & LF);
+ end if;
+
+ Put (S, "F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;" & LF);
+ Put (S, "Slot_Off : constant Field_Offset := Off / F_Per_Slot;" & LF);
+
+ if In_NH then
+ Put (S, "S : Slot renames Node_Offsets.Table (" & N & ").Slots (Slot_Off);" & LF);
+ else
+ Put (S, "S : Slot renames Slots.Table (Node_Offsets.Table (" & N & ").Offset + Slot_Off);" & LF);
+ end if;
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "V : constant Natural := Natural ((Off mod F_Per_Slot) * F_Size);" & LF);
+ Put (S, LF);
+ end if;
+ end Put_Getter_Setter_Locals;
+
---------------------
-- Put_Getter_Body --
---------------------
procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
+ F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
+ T : constant String := Get_Set_Id_Image (Rec.Field_Type);
begin
-- Note that we store the result in a local constant below, so that
-- the "Pre => ..." can refer to it. The constant is called Val so
@@ -1767,16 +1621,44 @@
-- and setter.
Put_Getter_Spec (S, F);
- Put (S, " is" & LF);
- Increase_Indent (S, 3);
- Put (S, "Val : constant " & Get_Set_Id_Image (Rec.Field_Type) &
- " := " & Low_Level_Getter_Name (Rec.Field_Type) &
- " (" & Node_To_Fetch_From (F) & ", " &
- Image (Rec.Offset) & ");" & LF);
+ Put_Getter_Setter_Locals (S, F, Get => True);
+
+ Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit :=" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "Field_Size_" & Image (F_Size) & "_Bit (");
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "Shift_Right (S, V) and Mask);" & LF);
+ else
+ Put (S, "S);" & LF);
+ end if;
+
+ Decrease_Indent (S, 2);
+
+ Put (S, "Val : constant " & T & " :=");
+
+ if Field_Has_Special_Default (Rec.Field_Type) then
+ pragma Assert (Field_Size (Rec.Field_Type) = 32);
+ Put (S, LF);
+ Increase_Indent (S, 2);
+ Put (S, "(if Raw = 0 then " & Special_Default (Rec.Field_Type) &
+ " else " & "Cast (Raw));");
+ Decrease_Indent (S, 2);
+
+ else
+ Put (S, " Cast (Raw);");
+ end if;
+
+ Put (S, LF);
+
Decrease_Indent (S, 3);
Put (S, "begin" & LF);
Increase_Indent (S, 3);
+ Put (S, "-- pragma Debug (Validate_Node_And_Offset (NN, Slot_Off));" & LF);
+ -- Comment out the validation, because it's too slow, and because the
+ -- relevant routines in Atree are not visible.
+
if Rec.Pre.all /= "" then
Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
end if;
@@ -1785,6 +1667,7 @@
Put (S, "pragma Assert (" & Rec.Pre_Get.all & ");" & LF);
end if;
+ Put_Get_Set_Incr (S, F, "Get");
Put (S, "return Val;" & LF);
Decrease_Indent (S, 3);
Put (S, "end " & Image (F) & ";" & LF & LF);
@@ -1824,6 +1707,7 @@
procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is
Rec : Field_Info renames Field_Table (F).all;
+ F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
-- If Type_Only was specified in the call to Create_Semantic_Field,
-- then we assert that the node is a base type. We cannot assert that
@@ -1836,10 +1720,18 @@
"Is_Base_Type (N)");
begin
Put_Setter_Spec (S, F);
- Put (S, " is" & LF);
+ Put_Getter_Setter_Locals (S, F, Get => False);
+
+ Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit := Cast (Val);" & LF);
+
+ Decrease_Indent (S, 3);
Put (S, "begin" & LF);
Increase_Indent (S, 3);
+ Put (S, "-- pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));" & LF);
+ -- Comment out the validation, because it's too slow, and because the
+ -- relevant routines in Atree are not visible.
+
if Rec.Pre.all /= "" then
Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
end if;
@@ -1852,8 +1744,29 @@
Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF);
end if;
- Put (S, Low_Level_Setter_Name (F) & " (N, " & Image (Rec.Offset)
- & ", Val);" & LF);
+ if Setter_Needs_Parent (F) then
+ declare
+ Err : constant String :=
+ (if Rec.Field_Type = List_Id then "Error_List" else "Error");
+ begin
+ Put (S, "if Present (Val) and then Val /= " & Err & " then" & LF);
+ Increase_Indent (S, 3);
+ Put (S, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
+ Put (S, "Set_Parent (Val, N);" & LF);
+ Put (S, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
+ Decrease_Indent (S, 3);
+ Put (S, "end if;" & LF & LF);
+ end;
+ end if;
+
+ if Field_Size (Rec.Field_Type) /= SS then
+ Put (S, "S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Raw), V);" & LF);
+
+ else
+ Put (S, "S := Slot (Raw);" & LF);
+ end if;
+
+ Put_Get_Set_Incr (S, F, "Set");
Decrease_Indent (S, 3);
Put (S, "end Set_" & Image (F) & ";" & LF & LF);
end Put_Setter_Body;
@@ -2076,7 +1989,7 @@
when others => "Entity_Field"); -- Entity_Kind
begin
- Put (S, "-- Table of sizes in 32-bit slots for given " &
+ Put (S, "-- Table of sizes in " & SSS & "-bit slots for given " &
Image (Root) & ", for use by Atree:" & LF);
case Root is
@@ -2085,8 +1998,7 @@
Image (Min_Node_Size) & ";" & LF);
Put (S, "Max_Node_Size : constant Field_Offset := " &
Image (Max_Node_Size) & ";" & LF & LF);
- Put (S, "Average_Node_Size_In_Slots : constant := " &
- Average_Node_Size_In_Slots'Img & ";" & LF & LF);
+
when Entity_Kind =>
Put (S, LF & "Min_Entity_Size : constant Field_Offset := " &
Image (Min_Entity_Size) & ";" & LF);
@@ -2107,34 +2019,48 @@
Put (S, "); -- Size" & LF);
Decrease_Indent (S, 2);
- declare
- type Dummy is array
- (First_Field (Root) .. Last_Field (Root)) of Boolean;
- Num_Fields : constant Root_Int := Dummy'Length;
- First_Time : Boolean := True;
- begin
- Put (S, LF & "-- Enumeration of all " & Image (Num_Fields)
- & " fields:" & LF & LF);
+ if Root = Node_Kind then
+ declare
+ type Node_Dummy is array (Node_Field) of Boolean;
+ type Entity_Dummy is array (Entity_Field) of Boolean;
+ Num_Fields : constant Root_Int :=
+ Node_Dummy'Length + Entity_Dummy'Length;
+ First_Time : Boolean := True;
+ begin
+ Put (S, LF & "-- Enumeration of all " & Image (Num_Fields)
+ & " fields:" & LF & LF);
- Put (S, "type " & Field_Enum_Type_Name & " is" & LF);
- Increase_Indent (S, 2);
- Put (S, "(");
- Increase_Indent (S, 1);
+ Put (S, "type Node_Or_Entity_Field is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
- for F in First_Field (Root) .. Last_Field (Root) loop
- if First_Time then
- First_Time := False;
- else
+ for F in Node_Field loop
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, "," & LF);
+ end if;
+
+ Put (S, F_Image (F));
+ end loop;
+
+ for F in Entity_Field loop
Put (S, "," & LF);
- end if;
+ Put (S, F_Image (F));
+ end loop;
- Put (S, F_Image (F));
- end loop;
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Node_Or_Entity_Field" & LF);
+ Decrease_Indent (S, 2);
+ end;
+ end if;
- Decrease_Indent (S, 1);
- Put (S, "); -- " & Field_Enum_Type_Name & LF);
- Decrease_Indent (S, 2);
- end;
+ Put (S, LF & "subtype " & Field_Enum_Type_Name & " is" & LF);
+ Increase_Indent (S, 2);
+ Put (S, "Node_Or_Entity_Field range " & F_Image (First_Field (Root)) &
+ " .. " & F_Image (Last_Field (Root)) & ";" & LF);
+ Decrease_Indent (S, 2);
Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF);
Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" &
@@ -2193,34 +2119,67 @@
Decrease_Indent (S, 2);
end;
- declare
- First_Time : Boolean := True;
- begin
- Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF);
+ if Root = Node_Kind then
+ declare
+ First_Time : Boolean := True;
+ FS, FB, LB : Bit_Offset;
+ -- Field size in bits, first bit, and last bit for the previous
+ -- time around the loop. Used to print a comment after ",".
- Put (S, Field_Enum_Type_Name & "_Descriptors : constant array (" &
- Field_Enum_Type_Name & ") of Field_Descriptor :=" & LF);
+ procedure One_Comp (F : Field_Enum);
- Increase_Indent (S, 2);
- Put (S, "(");
- Increase_Indent (S, 1);
+ procedure One_Comp (F : Field_Enum) is
+ pragma Annotate (Codepeer, Modified, Field_Table);
+ Offset : constant Field_Offset := Field_Table (F).Offset;
+ begin
+ if First_Time then
+ First_Time := False;
+ else
+ Put (S, ",");
- for F in First_Field (Root) .. Last_Field (Root) loop
- if First_Time then
- First_Time := False;
- else
- Put (S, "," & LF);
- end if;
+ -- Print comment showing field's bits, except for 1-bit
+ -- fields.
- Put (S, F_Image (F) & " => (" &
- Image (Field_Table (F).Field_Type) & "_Field, " &
- Image (Field_Table (F).Offset) & ")");
- end loop;
+ if FS /= 1 then
+ Put (S, " -- *" & Image (FS) & " = bits " &
+ Image (FB) & ".." & Image (LB));
+ end if;
- Decrease_Indent (S, 1);
- Put (S, "); -- Field_Descriptors" & LF);
- Decrease_Indent (S, 2);
- end;
+ Put (S, LF);
+ end if;
+
+ Put (S, F_Image (F) & " => (" &
+ Image (Field_Table (F).Field_Type) & "_Field, " &
+ Image (Offset) & ")");
+
+ FS := Field_Size (F);
+ FB := First_Bit (F, Offset);
+ LB := Last_Bit (F, Offset);
+ end One_Comp;
+
+ begin
+ Put (S, LF & "-- Table mapping fields to kind and offset:" & LF & LF);
+
+ Put (S, "Field_Descriptors : constant array (" &
+ "Node_Or_Entity_Field) of Field_Descriptor :=" & LF);
+
+ Increase_Indent (S, 2);
+ Put (S, "(");
+ Increase_Indent (S, 1);
+
+ for F in Node_Field loop
+ One_Comp (F);
+ end loop;
+
+ for F in Entity_Field loop
+ One_Comp (F);
+ end loop;
+
+ Decrease_Indent (S, 1);
+ Put (S, "); -- Field_Descriptors" & LF);
+ Decrease_Indent (S, 2);
+ end;
+ end if;
end Put_Tables;
@@ -2291,7 +2250,16 @@
Put (S, "Kind : Field_Kind;" & LF);
Put (S, "Offset : Field_Offset;" & LF);
Decrease_Indent (S, 3);
- Put (S, "end record;" & LF);
+ Put (S, "end record;" & LF & LF);
+
+ -- Print out the node header types. Note that the Offset field is of
+ -- the base type, because we are using zero-origin addressing in
+ -- Atree.
+
+ Put (S, "N_Head : constant Field_Offset := " & N_Head & ";" & LF & LF);
+
+ Put (S, "Atree_Statistics_Enabled : constant Boolean := " &
+ Capitalize (Boolean'Image (Statistics_Enabled)) & ";" & LF);
Decrease_Indent (S, 3);
Put (S, LF & "end Seinfo;" & LF);
@@ -2305,39 +2273,6 @@
S : Sink;
B : Sink;
- procedure Put_Setter_With_Parent (Kind : String);
- -- Put the low-level ..._With_Parent setter. Kind is either "Node" or
- -- "List".
-
- procedure Put_Setter_With_Parent (Kind : String) is
- Error : constant String := (if Kind = "Node" then "" else "_" & Kind);
- begin
- Put (B, LF & "procedure Set_" & Kind & "_Id_With_Parent" & LF);
- Increase_Indent (B, 2);
- Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id);" & LF & LF);
- Decrease_Indent (B, 2);
-
- Put (B, "procedure Set_" & Kind & "_Id_With_Parent" & LF);
- Increase_Indent (B, 2);
- Put (B, "(N : Node_Id; Offset : Field_Offset; Val : " & Kind & "_Id) is" & LF);
- Decrease_Indent (B, 2);
- Put (B, "begin" & LF);
- Increase_Indent (B, 3);
- Put (B, "if Present (Val) and then Val /= Error" & Error & " then" & LF);
- Increase_Indent (B, 3);
- Put (B, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
- Put (B, "Set_Parent (Val, N);" & LF);
- Put (B, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
- Decrease_Indent (B, 3);
- Put (B, "end if;" & LF & LF);
-
- Put (B, "Set_" & Kind & "_Id (N, Offset, Val);" & LF);
- Decrease_Indent (B, 3);
- Put (B, "end Set_" & Kind & "_Id_With_Parent;" & LF);
- end Put_Setter_With_Parent;
-
- -- Start of processing for Put_Nodes
-
begin
Create_File (S, "sinfo-nodes.ads");
Create_File (B, "sinfo-nodes.adb");
@@ -2369,6 +2304,7 @@
Decrease_Indent (S, 3);
Put (S, LF & "end Sinfo.Nodes;" & LF);
+ Put (B, "with Unchecked_Conversion;" & LF);
Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
Put (B, "with Nlists; use Nlists;" & LF);
Put (B, "pragma Warnings (Off);" & LF);
@@ -2381,19 +2317,14 @@
Put (B, "-- This package is automatically generated." & LF & LF);
- Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
- Put (B, "-- in units of the size of the field." & LF);
-
Put (B, "pragma Style_Checks (""M200"");" & LF);
+
for T in Special_Type loop
if Node_Field_Types_Used (T) then
- Put_Low_Level_Accessor_Instantiations (B, T);
+ Put_Casts (B, T);
end if;
end loop;
- Put_Setter_With_Parent ("Node");
- Put_Setter_With_Parent ("List");
-
Put_Subp_Bodies (B, Node_Kind);
Decrease_Indent (B, 3);
@@ -2411,7 +2342,6 @@
begin
Create_File (S, "einfo-entities.ads");
Create_File (B, "einfo-entities.adb");
- Put (S, "with Seinfo; use Seinfo;" & LF);
Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
Put (S, LF & "package Einfo.Entities is" & LF & LF);
@@ -2430,6 +2360,7 @@
Decrease_Indent (S, 3);
Put (S, LF & "end Einfo.Entities;" & LF);
+ Put (B, "with Unchecked_Conversion;" & LF);
Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
-- This forms a cycle between packages (via bodies, which is OK)
@@ -2439,13 +2370,11 @@
Put (B, "-- This package is automatically generated." & LF & LF);
- Put (B, "-- Instantiations of low-level getters and setters that take offsets" & LF);
- Put (B, "-- in units of the size of the field." & LF);
-
Put (B, "pragma Style_Checks (""M200"");" & LF);
+
for T in Special_Type loop
if Entity_Field_Types_Used (T) then
- Put_Low_Level_Accessor_Instantiations (B, T);
+ Put_Casts (B, T);
end if;
end loop;
@@ -2494,7 +2423,8 @@
end if;
end loop;
- Put (S, ")" & LF & "return " & Node_Or_Entity (Root) & "_Id");
+ Put (S, ")" & LF);
+ Put (S, "return " & Node_Or_Entity (Root) & "_Id");
Decrease_Indent (S, 2);
Decrease_Indent (S, 1);
end Put_Make_Spec;
@@ -2714,11 +2644,11 @@
return Result : Bit_Offset do
if F = No_Field then
-- We don't have a field size for No_Field, so just look at
- -- the bits up to the next word boundary.
+ -- the bits up to the next slot boundary.
Result := First_Bit;
- while (Result + 1) mod 32 /= 0
+ while (Result + 1) mod SS /= 0
and then Type_Layout (T) (Result + 1) = No_Field
loop
Result := Result + 1;
@@ -2731,19 +2661,19 @@
end Get_Last_Bit;
function First_Bit_Image (First_Bit : Bit_Offset) return String is
- W : constant Bit_Offset := First_Bit / 32;
- B : constant Bit_Offset := First_Bit mod 32;
- pragma Assert (W * 32 + B = First_Bit);
+ W : constant Bit_Offset := First_Bit / SS;
+ B : constant Bit_Offset := First_Bit mod SS;
+ pragma Assert (W * SS + B = First_Bit);
begin
return
- Image (W) & "*32" & (if B = 0 then "" else " + " & Image (B));
+ Image (W) & "*" & SSS & (if B = 0 then "" else " + " & Image (B));
end First_Bit_Image;
function Last_Bit_Image (Last_Bit : Bit_Offset) return String is
- W : constant Bit_Offset := (Last_Bit + 1) / 32;
+ W : constant Bit_Offset := (Last_Bit + 1) / SS;
begin
- if W * 32 - 1 = Last_Bit then
- return Image (W) & "*32 - 1";
+ if W * SS - 1 = Last_Bit then
+ return Image (W) & "*" & SSS & " - 1";
else
return First_Bit_Image (Last_Bit);
end if;
@@ -2857,6 +2787,7 @@
declare
First_Time : Boolean := True;
+
begin
for T in Concrete_Type loop
if First_Time then
@@ -2878,40 +2809,45 @@
declare
First_Time : Boolean := True;
First_Bit : Bit_Offset := 0;
+ F : Opt_Field_Enum;
+
+ function Node_Field_Of_Entity return String is
+ (if T in Entity_Type and then F in Node_Field then
+ " -- N" else "");
+ -- A comment to put out for fiel